suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

windows: extflonum support

Browse Source 
Enable extflonums in a MSVC build by relying on a MinGW-built DLL,
"longdouble.dll". The DLL is loaded on startup. If the DLL isn't
available, then `extflonum-available?' reports #f.

Instead of setting the floating-point mode globally to extended
precision, the mode is changed only just before (and restored right
after) extflonum arithmetic operations.
This commit is contained in:
Michael Filonenko 2013-03-04 19:15:15 +04:00 committed by Matthew Flatt
parent ccc8b85cef
commit 35a093469c
39 changed files with 1703 additions and 456 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/compiler/distribute.rkt
View File

@ -150,7 +150,8 @@
(map copy-dll (list
(if (equal? "win32\\x86_64" (path->string (system-library-subpath #f)))
"libiconv-2.dll"
"iconv.dll")))
"iconv.dll")
"longdouble.dll"))
(when (or (memq 'racketcgc types)
(memq 'gracketcgc types))
(map copy-dll

3
collects/scribblings/reference/extflonums.scrbl
View File

@ -12,7 +12,8 @@ platforms with extended-precision hardware and where the
extflonum implementation does not conflict with normal
double-precision arithmetic (i.e., on x86 and x86_64 platforms when
Racket is compiled to use SSE instructions for floating-point
operations).
operations, and on Windows when @as-index{@filepath{longdouble.dll}}
is available).
A extflonum is @bold{not} a @tech{number} in the sense of
@racket[number?]. Only extflonum-specific operations such as

4
src/README
View File

@ -382,6 +382,10 @@ is compiling floating-point operations as SSE, so be sure to include
flags like "-mfpmath=sse" or "-mfpmath=387" in CPPFLAGS, and not just
CFLAGS. See related configuration options below.
The Windows build enables extflonum support through a MinGW-compiled
"longdouble.dll", since MSVC does not support `long double' as
extended-precision floating point.
Configuration Options
---------------------

56
src/foreign/foreign.c
View File

@ -597,6 +597,9 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/*****************************************************************************/
/* Types */
#define MZ_TYPE_CAST(t, e) (t)(e)
#define MZ_NO_TYPE_CAST(t, e) (e)
/***********************************************************************
* The following are the only primitive types.
* The tricky part is figuring out what width-ed types correspond to
@ -780,12 +783,19 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* C->Racket: scheme_make_double(<C>)
*/
#ifdef _MSC_VER
struct struct_align_slongdouble {
char c;
long_double x;
};
const ffi_type ffi_type_slongdouble = {
sizeof(long_double),
offsetof(struct struct_align_slongdouble, x),
FFI_TYPE_STRUCT, NULL
};
#else /* _MSC_VER undefined */
#define ffi_type_slongdouble ffi_type_longdouble
#ifdef MZ_LONG_DOUBLE
typedef long double mz_long_double;
#else /* MZ_LONG_DOUBLE undefined */
typedef double mz_long_double;
#endif /* MZ_LONG_DOUBLE */
#endif /* _MSC_VER */
#ifdef MZ_LONG_DOUBLE
#define SCHEME_MAYBE_LONG_DBL_VAL(x) SCHEME_LONG_DBL_VAL(x)
#else /* MZ_LONG_DOUBLE undefined */
@ -804,6 +814,7 @@ static Scheme_Object *unsupported_make_long_double() {
return NULL;
}
#endif /* MZ_LONG_DOUBLE */
#define FOREIGN_longdouble (16)
/* Type Name: longdouble
* LibFfi type: ffi_type_slongdouble
@ -814,6 +825,7 @@ static Scheme_Object *unsupported_make_long_double() {
* C->Racket: scheme_make_maybe_long_double(<C>)
*/
/* A double that will coerce numbers to doubles: */
#define FOREIGN_doubleS (17)
/* Type Name: double* (doubleS)
@ -1858,7 +1870,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_INTP(val)) {
Tsint32 tmp;
tmp = (Tsint32)(SCHEME_INT_VAL(val));
tmp = MZ_TYPE_CAST(Tsint32, SCHEME_INT_VAL(val));
(((Tsint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_fixint", val);;
@ -1873,7 +1885,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_INTP(val)) {
Tuint32 tmp;
tmp = (Tuint32)(SCHEME_UINT_VAL(val));
tmp = MZ_TYPE_CAST(Tuint32, SCHEME_UINT_VAL(val));
(((Tuint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_ufixint", val);;
@ -1888,7 +1900,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_INTP(val)) {
intptr_t tmp;
tmp = (intptr_t)(SCHEME_INT_VAL(val));
tmp = MZ_TYPE_CAST(intptr_t, SCHEME_INT_VAL(val));
(((intptr_t*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_fixnum", val);;
@ -1903,7 +1915,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_INTP(val)) {
uintptr_t tmp;
tmp = (uintptr_t)(SCHEME_UINT_VAL(val));
tmp = MZ_TYPE_CAST(uintptr_t, SCHEME_UINT_VAL(val));
(((uintptr_t*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_ufixnum", val);;
@ -1918,7 +1930,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FLOATP(val)) {
float tmp;
tmp = (float)(SCHEME_FLOAT_VAL(val));
tmp = MZ_TYPE_CAST(float, SCHEME_FLOAT_VAL(val));
(((float*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_float", val);;
@ -1933,7 +1945,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FLOATP(val)) {
double tmp;
tmp = (double)(SCHEME_FLOAT_VAL(val));
tmp = MZ_TYPE_CAST(double, SCHEME_FLOAT_VAL(val));
(((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_double", val);;
@ -1948,7 +1960,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_LONG_DBLP(val)) {
mz_long_double tmp;
tmp = (mz_long_double)(SCHEME_MAYBE_LONG_DBL_VAL(val));
tmp = MZ_NO_TYPE_CAST(mz_long_double, SCHEME_MAYBE_LONG_DBL_VAL(val));
(((mz_long_double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_longdouble", val);;
@ -1963,7 +1975,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_REALP(val)) {
double tmp;
tmp = (double)(scheme_real_to_double(val));
tmp = MZ_TYPE_CAST(double, scheme_real_to_double(val));
(((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_double*", val);;
@ -1978,7 +1990,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (1) {
int tmp;
tmp = (int)(SCHEME_TRUEP(val));
tmp = MZ_TYPE_CAST(int, SCHEME_TRUEP(val));
(((int*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_bool", val);;
@ -1993,7 +2005,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
mzchar* tmp;
tmp = (mzchar*)(ucs4_string_or_null_to_ucs4_pointer(val));
tmp = MZ_TYPE_CAST(mzchar*, ucs4_string_or_null_to_ucs4_pointer(val));
if (basetype_p == NULL || tmp == NULL || 0) {
(((mzchar**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
@ -2014,7 +2026,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
unsigned short* tmp;
tmp = (unsigned short*)(ucs4_string_or_null_to_utf16_pointer(val));
tmp = MZ_TYPE_CAST(unsigned short*, ucs4_string_or_null_to_utf16_pointer(val));
if (basetype_p == NULL || tmp == NULL || 0) {
(((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
@ -2035,7 +2047,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FALSEP(val)||SCHEME_BYTE_STRINGP(val)) {
char* tmp;
tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_BYTE_STR_VAL(val));
tmp = MZ_TYPE_CAST(char*, SCHEME_FALSEP(val)?NULL:SCHEME_BYTE_STR_VAL(val));
if (basetype_p == NULL || tmp == NULL || 0) {
(((char**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
@ -2056,7 +2068,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FALSEP(val)||SCHEME_PATH_STRINGP(val)) {
char* tmp;
tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_PATH_VAL(TO_PATH(val)));
tmp = MZ_TYPE_CAST(char*, SCHEME_FALSEP(val)?NULL:SCHEME_PATH_VAL(TO_PATH(val)));
if (basetype_p == NULL || tmp == NULL || 0) {
(((char**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
@ -2077,7 +2089,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_SYMBOLP(val)) {
char* tmp;
tmp = (char*)(SCHEME_SYM_VAL(val));
tmp = MZ_TYPE_CAST(char*, SCHEME_SYM_VAL(val));
if (basetype_p == NULL || tmp == NULL || !is_gcable_pointer(val)) {
(((char**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
@ -2098,7 +2110,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FFIANYPTRP(val)) {
void* tmp; intptr_t toff;
tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
tmp = MZ_TYPE_CAST(void*, SCHEME_FFIANYPTR_VAL(val));
toff = SCHEME_FFIANYPTR_OFFSET(val);
if (basetype_p == NULL || (tmp == NULL && toff == 0) || !is_gcable_pointer(val)) {
if (_offset) *_offset = 0;
@ -2123,7 +2135,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_FFIANYPTRP(val)) {
void* tmp; intptr_t toff;
tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
tmp = MZ_TYPE_CAST(void*, SCHEME_FFIANYPTR_VAL(val));
toff = SCHEME_FFIANYPTR_OFFSET(val);
if (basetype_p == NULL || (tmp == NULL && toff == 0) || 0) {
if (_offset) *_offset = 0;
@ -2148,7 +2160,7 @@ static void* SCHEME2C(const char *who,
# endif /* SCHEME_BIG_ENDIAN */
if (1) {
Scheme_Object* tmp;
tmp = (Scheme_Object*)(val);
tmp = MZ_TYPE_CAST(Scheme_Object*, val);
if (basetype_p == NULL || tmp == NULL || 0) {
(((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;

41
src/foreign/foreign.rktc
View File

@ -516,6 +516,9 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/*****************************************************************************/
/* Types */
@DEFINE{MZ_TYPE_CAST(t, e) (t)(e)}
@DEFINE{MZ_NO_TYPE_CAST(t, e) (e)}
@(begin
;; Types are defined with the `defctype' function. This looks like:
;; (defctype 'type-name
@ -597,10 +600,11 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
[pred (prop 'pred (and macro @list{SCHEME_@|macro|P}))]
[s->c (prop 's->c (and macro @list{SCHEME_@|macro|_VAL}))]
[c->s (prop 'c->s)]
[offset (prop 'offset #f)])
[offset (prop 'offset #f)]
[cast (prop 'cast 'MZ_TYPE_CAST)])
(output (describe-type stype cname ftype ctype pred s->c c->s offset))
`(,type (stype ,stype) (cname ,cname) (ftype ,ftype) (ctype ,ctype)
(macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset))))
(macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset) (cast ,cast))))
(define (defctype name . args)
(set! types (append types (list (make-ctype name args)))))
@ -625,7 +629,8 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
[s->c (id 's->c)]
[c->s (id 'c->s)]
[offset (id 'offset)]
[ptr? (id 'ptr?)])
[ptr? (id 'ptr?)]
[cast (id 'cast)])
#'(maplines #:semicolons? 'semi?
(lambda (t)
(define data (cdr t))
@ -640,11 +645,12 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
[c->s (get 'c->s)]
[offset (get 'offset)]
[ptr? (or (equal? "pointer" ftype)
(equal? "gcpointer" ftype))])
(equal? "gcpointer" ftype))]
[cast (get 'cast)])
body ...))
types)))]))
(define (defctype* name/+ftype ctype pred s->c c->s)
(define (defctype* name/+ftype ctype pred s->c c->s . more)
(let ([name (if (pair? name/+ftype) (car name/+ftype) name/+ftype)]
[ftype (and (pair? name/+ftype) (cadr name/+ftype))])
(apply defctype name
@ -652,7 +658,8 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
,@(if ftype `(ftype ,ftype) `())
pred ,(if (string? pred) @list{SCHEME_@|pred|P} pred)
s->c ,(if (string? s->c) @list{SCHEME_@|s->c|_VAL} s->c)
c->s ,(if (string? c->s) @list{scheme_make_@|c->s|} c->s)))))
c->s ,(if (string? c->s) @list{scheme_make_@|c->s|} c->s)
,@more))))
)
@ -739,8 +746,19 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
@(defctype* 'double "double" "FLOAT" "FLOAT" "double")
#define ffi_type_slongdouble ffi_type_longdouble
@@@IFDEF{MZ_LONG_DOUBLE}{typedef long double mz_long_double;}{typedef double mz_long_double;}
@@@IFDEF{_MSC_VER}{
struct struct_align_slongdouble {
char c;
long_double x;
};
const ffi_type ffi_type_slongdouble = {
sizeof(long_double),
offsetof(struct struct_align_slongdouble, x),
FFI_TYPE_STRUCT, NULL
};
}{
@DEFINE{ffi_type_slongdouble ffi_type_longdouble}
}
@@@IFDEF{MZ_LONG_DOUBLE}{
@DEFINE{SCHEME_MAYBE_LONG_DBL_VAL(x) SCHEME_LONG_DBL_VAL(x)}
}{
@ -759,7 +777,10 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
return NULL;
}
}
@(defctype* '(longdouble "longdouble") "mz_long_double" "LONG_DBL" "MAYBE_LONG_DBL" "maybe_long_double")
@(defctype* '(longdouble "longdouble") "mz_long_double" "LONG_DBL" "MAYBE_LONG_DBL" "maybe_long_double"
'cast 'MZ_NO_TYPE_CAST)
/* A double that will coerce numbers to doubles: */
@(defctype* '(double* "double") "double"
@ -1544,7 +1565,7 @@ static void* SCHEME2C(const char *who,
}}
if (@f[pred]) {
@ctype tmp@";"@and[offset]{ intptr_t toff@";"}
tmp = (@ctype)(@f[s->c]);
tmp = @cast(@ctype, @f[s->c]);
@and[offset @list{toff = SCHEME_@|offset|_OFFSET(val);@"\n"}]@;
@(if ptr?
@list{if (basetype_p == NULL || @;

6
src/get-libs.rkt
View File

@ -16,11 +16,13 @@
[win32/i386
["iconv.dll" 892928]
["libeay32.dll" 1099776]
["ssleay32.dll" 239104]]
["ssleay32.dll" 239104]
["longdouble.dll" 113285]]
[win32/x86_64
["libiconv-2.dll" 1378028]
["libeay32.dll" 1503232]
["ssleay32.dll" 309760]]]
["ssleay32.dll" 309760]
["longdouble.dll" 123031]]]
;; Math Libraries
'[math
[i386-macosx

16
src/racket/include/scheme.h
View File

@ -83,6 +83,18 @@
# endif
#endif
#ifdef MZ_LONG_DOUBLE
# if defined(_MSC_VER)
# define MZ_NEED_SET_EXTFL_MODE 1
# define BYTES_RESERVED_FOR_LONG_DOUBLE 16
typedef struct {
char bytes[BYTES_RESERVED_FOR_LONG_DOUBLE];
} mz_long_double;
# else
typedef long double mz_long_double;
# endif
#endif
#ifdef DONT_ITIMER
# undef USE_ITIMER
#endif
@ -351,7 +363,7 @@ typedef struct {
#ifdef MZ_LONG_DOUBLE
typedef struct {
Scheme_Object so;
long double long_double_val;
mz_long_double long_double_val;
} Scheme_Long_Double;
#else
typedef struct {
@ -393,7 +405,7 @@ typedef struct Scheme_Double_Vector {
typedef struct Scheme_Long_Double_Vector {
Scheme_Inclhash_Object iso; /* & 0x2 indicates allocated in the MASTERGC */
intptr_t size;
long double els[mzFLEX_ARRAY_DECL];
mz_long_double els[mzFLEX_ARRAY_DECL];
} Scheme_Long_Double_Vector;
#endif

4
src/racket/include/schthread.h
View File

@ -164,8 +164,8 @@ typedef struct Thread_Local_Variables {
double scheme_jit_save_fp_;
double scheme_jit_save_fp2_;
#ifdef MZ_LONG_DOUBLE
long double scheme_jit_save_extfp_;
long double scheme_jit_save_extfp2_;
mz_long_double scheme_jit_save_extfp_;
mz_long_double scheme_jit_save_extfp2_;
#endif
struct Scheme_Bucket_Table *starts_table_;
struct Scheme_Bucket_Table *submodule_empty_modidx_table_;

1
src/racket/main.c
View File

@ -1,3 +1,4 @@
/*
Racket
Copyright (c) 2004-2013 PLT Design Inc.

1
src/racket/sconfig.h
View File

@ -640,6 +640,7 @@
# define USE_ICONV_DLL
# define NO_MBTOWC_FUNCTIONS
# define MZ_LONG_DOUBLE
# ifdef _WIN64
# define MZ_USE_JIT_X86_64
# else

3
src/racket/src/Makefile.in
View File

@ -292,7 +292,8 @@ SCONFIG = $(srcdir)/../sconfig.h $(srcdir)/../uconfig.h ../mzconfig.h
# More dependencies
COMMON_HEADERS = $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
$(srcdir)/../include/schthread.h $(srcdir)/mzrt.h $(srcdir)/mzrt_cas.inc
$(srcdir)/../include/schthread.h $(srcdir)/mzrt.h $(srcdir)/mzrt_cas.inc \
$(srcdir)/longdouble/longdouble.h
JIT_HEADERS = $(srcdir)/../src/jit.h $(srcdir)/../src/jitfpu.h \
$(srcdir)/../src/stypes.h \
$(srcdir)/lightning/i386/core.h $(srcdir)/lightning/i386/core-common.h \

37
src/racket/src/bgnfloat.inc
View File

@ -41,8 +41,8 @@ FP_TYPE SCHEME_BIGNUM_TO_FLOAT_INFO(const Scheme_Object *n, intptr_t skip, intpt
d = FP_ZEROx;
while (nl--) {
d *= (FP_TYPE)BIG_RADIX;
d += *(--na);
d = FP_TYPE_MULT(d, FP_TYPE_FROM_DOUBLE(BIG_RADIX));
d = FP_TYPE_PLUS(d, FP_TYPE_FROM_UINTPTR(*(--na)));
if (IS_FLOAT_INF(d))
break;
--skipped;
@ -52,7 +52,7 @@ FP_TYPE SCHEME_BIGNUM_TO_FLOAT_INFO(const Scheme_Object *n, intptr_t skip, intpt
*_skipped = skipped;
if (!SCHEME_BIGPOS(n))
d = -d;
d = FP_TYPE_NEG(d);
return d;
}
@ -77,42 +77,42 @@ Scheme_Object *SCHEME_BIGNUM_FROM_FLOAT(FP_TYPE d)
SCHEME_CHECK_FLOAT("inexact->exact", d, "integer");
if (d < FP_ZEROx) {
if (FP_TYPE_LESS(d, FP_ZEROx)) {
negate = 1;
d = -d;
d = FP_TYPE_NEG(d);
} else
negate = 0;
if (d < FP_ONEx)
if (FP_TYPE_LESS(d, FP_ONEx))
return scheme_make_integer(0);
log = 0;
while (r < d) {
while (FP_TYPE_LESS(r, d)) {
log++;
r *= FP_TWOx;
r = FP_TYPE_MULT(r, FP_TWOx);
}
if (log > USE_FLOAT_BITS) {
times = log - USE_FLOAT_BITS;
log = USE_FLOAT_BITS;
for (i = 0; i < times; i++) {
d /= FP_TWOx;
d = FP_TYPE_DIV(d, FP_TWOx);
}
} else
times = 0;
r = pow(FP_TWOx, (FP_TYPE)log);
r = FP_POWx(FP_TWOx, FP_TYPE_FROM_INT(log));
n = scheme_make_small_bignum(0, &s1);
log++;
while (log--) {
bignum_double_inplace(&n);
if (d >= r) {
d -= r;
if (FP_TYPE_GREATER_OR_EQV(d, r)) {
d = FP_TYPE_MINUS(d, r);
bignum_add1_inplace(&n);
}
r /= FP_TWOx;
r = FP_TYPE_DIV(r, FP_TWOx);
}
if (times) {
@ -144,3 +144,14 @@ Scheme_Object *SCHEME_BIGNUM_FROM_FLOAT(FP_TYPE d)
#undef FP_POWx
#undef FP_MZ_IS_POS_INFINITY
#undef FP_scheme_floating_point_nzero
#undef FP_TYPE_FROM_DOUBLE
#undef FP_TYPE_NEG
#undef FP_TYPE_LESS
#undef FP_TYPE_MULT
#undef FP_TYPE_PLUS
#undef FP_TYPE_DIV
#undef FP_TYPE_FROM_INT
#undef FP_TYPE_GREATER_OR_EQV
#undef FP_TYPE_MINUS
#undef FP_TYPE_FROM_UINTPTR

44
src/racket/src/bignum.c
View File

@ -1424,6 +1424,18 @@ static void bignum_add1_inplace(Scheme_Object **_stk_o)
#define USE_FLOAT_BITS 53
#define FP_TYPE double
#define FP_TYPE_FROM_DOUBLE(x) (FP_TYPE)x
#define FP_TYPE_NEG(x) (-(x))
#define FP_TYPE_LESS(x, y) ((x)<(y))
#define FP_TYPE_MULT(x, y) ((x)*(y))
#define FP_TYPE_PLUS(x, y) ((x)+(y))
#define FP_TYPE_DIV(x, y) ((x)/(y))
#define FP_TYPE_FROM_INT(x) ((FP_TYPE)(x))
#define FP_TYPE_GREATER_OR_EQV(x, y) ((x)>=(y))
#define FP_TYPE_MINUS(x, y) ((x)-(y))
#define FP_TYPE_FROM_UINTPTR
#define IS_FLOAT_INF scheme__is_double_inf
#define SCHEME_BIGNUM_TO_FLOAT_INFO scheme_bignum_to_double_inf_info
#define SCHEME_BIGNUM_TO_FLOAT scheme_bignum_to_double
@ -1434,6 +1446,18 @@ static void bignum_add1_inplace(Scheme_Object **_stk_o)
#ifdef MZ_USE_SINGLE_FLOATS
# define USE_FLOAT_BITS 24
# define FP_TYPE float
# define FP_TYPE_FROM_DOUBLE(x) (FP_TYPE)x
#define FP_TYPE_NEG(x) (-(x))
#define FP_TYPE_LESS(x, y) ((x)<(y))
#define FP_TYPE_MULT(x, y) ((x)*(y))
#define FP_TYPE_PLUS(x, y) ((x)+(y))
#define FP_TYPE_DIV(x, y) ((x)/(y))
#define FP_TYPE_FROM_INT(x) ((FP_TYPE)(x))
#define FP_TYPE_GREATER_OR_EQV(x, y) ((x)>=(y))
#define FP_TYPE_MINUS(x, y) ((x)-(y))
# define FP_TYPE_FROM_UINTPTR
# define IS_FLOAT_INF scheme__is_float_inf
# define SCHEME_BIGNUM_TO_FLOAT_INFO scheme_bignum_to_float_inf_info
# define SCHEME_BIGNUM_TO_FLOAT scheme_bignum_to_float
@ -1444,16 +1468,26 @@ static void bignum_add1_inplace(Scheme_Object **_stk_o)
#ifdef MZ_LONG_DOUBLE
# define USE_FLOAT_BITS 64
# define FP_TYPE long double
# define FP_TYPE long_double
# define FP_TYPE_FROM_DOUBLE(x) long_double_from_double(x)
# define FP_TYPE_NEG(x) long_double_neg(x)
# define FP_TYPE_LESS(x, y) long_double_less(x, y)
# define FP_TYPE_MULT(x, y) long_double_mult(x, y)
# define FP_TYPE_DIV(x, y) long_double_div(x, y)
# define FP_TYPE_PLUS(x, y) long_double_plus(x, y)
# define FP_TYPE_FROM_INT(x) long_double_from_int(x)
# define FP_TYPE_GREATER_OR_EQV(x, y) long_double_greater_or_eqv(x, y)
# define FP_TYPE_MINUS(x, y) long_double_minus(x, y)
# define FP_TYPE_FROM_UINTPTR(x) long_double_from_uintptr(x)
# define IS_FLOAT_INF scheme__is_long_double_inf
# define SCHEME_BIGNUM_TO_FLOAT_INFO scheme_bignum_to_long_double_inf_info
# define SCHEME_BIGNUM_TO_FLOAT scheme_bignum_to_long_double
# define SCHEME_CHECK_FLOAT scheme_check_long_double
# define SCHEME_BIGNUM_FROM_FLOAT scheme_bignum_from_long_double
# define FP_ZEROx 0.0L
# define FP_ONEx 1.0L
# define FP_TWOx 2.0L
# define FP_POWx powl
# define FP_ZEROx get_long_double_zero()
# define FP_ONEx get_long_double_1()
# define FP_TWOx get_long_double_2()
# define FP_POWx long_double_pow
# define FP_MZ_IS_POS_INFINITY(x) MZ_IS_LONG_POS_INFINITY(x)
# define FP_scheme_floating_point_nzero scheme_long_floating_point_nzero
# include "bgnfloat.inc"

18
src/racket/src/bool.c
View File

@ -198,10 +198,10 @@ int scheme_eq (Scheme_Object *obj1, Scheme_Object *obj2)
}
#ifdef MZ_LONG_DOUBLE
XFORM_NONGCING static MZ_INLINE int long_double_eqv(long double a, long double b)
XFORM_NONGCING static MZ_INLINE int mz_long_double_eqv(long_double a, long_double b)
{
# ifndef NAN_EQUALS_ANYTHING
if (a != b) {
if (!long_double_eqv(a, b)) {
# endif
/* Double-check for NANs: */
if (MZ_IS_LONG_NAN(a)) {
@ -215,18 +215,18 @@ XFORM_NONGCING static MZ_INLINE int long_double_eqv(long double a, long double b
if (MZ_IS_LONG_NAN(b))
return 0;
else {
if (a == 0.0L) {
if (b == 0.0L) {
if (long_double_eqv(a, get_long_double_zero()) {
if (long_double_eqv(b, get_long_double_zero()) {
return scheme_long_minus_zero_p(a) == scheme_long_minus_zero_p(b);
}
}
return (a == b);
return long_double_eqv(a, b);
}
# else
return 0;
}
if (a == 0.0L) {
if (b == 0.0L) {
if (long_double_eqv(a, get_long_double_zero())) {
if (long_double_eqv(b, get_long_double_zero())) {
return scheme_long_minus_zero_p(a) == scheme_long_minus_zero_p(b);
}
}
@ -291,7 +291,7 @@ XFORM_NONGCING static int is_eqv(Scheme_Object *obj1, Scheme_Object *obj2)
return -1;
#ifdef MZ_LONG_DOUBLE
} else if (t1 == scheme_long_double_type) {
return long_double_eqv(SCHEME_LONG_DBL_VAL(obj1), SCHEME_LONG_DBL_VAL(obj2));
return mz_long_double_eqv(SCHEME_LONG_DBL_VAL(obj1), SCHEME_LONG_DBL_VAL(obj2));
#endif
#ifdef MZ_USE_SINGLE_FLOATS
} else if (t1 == scheme_float_type) {
@ -530,7 +530,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
l2 = SCHEME_EXTFLVEC_SIZE(obj2);
if (l1 == l2) {
for (i = 0; i < l1; i++) {
if (!long_double_eqv(SCHEME_EXTFLVEC_ELS(obj1)[i],
if (!mz_long_double_eqv(SCHEME_EXTFLVEC_ELS(obj1)[i],
SCHEME_EXTFLVEC_ELS(obj2)[i]))
return 0;
}

4
src/racket/src/env.c
View File

@ -239,6 +239,10 @@ Scheme_Env *scheme_engine_instance_init()
printf("#if 0\nengine_instance_init @ %" PRIdPTR "\n", scheme_get_process_milliseconds());
#endif
#ifdef MZ_LONG_DOUBLE_API_IS_EXTERNAL
scheme_load_long_double_dll();
#endif
scheme_starting_up = 1;
scheme_init_finalization();

3
src/racket/src/file.c
View File

@ -6388,9 +6388,6 @@ Scheme_Object *scheme_find_links_path(int argc, Scheme_Object *argv[])
static wchar_t *dlldir;
__declspec(dllexport) wchar_t *scheme_get_dll_path(wchar_t *s);
__declspec(dllexport) void scheme_set_dll_path(wchar_t *p);
wchar_t *scheme_get_dll_path(wchar_t *s)
{
if (dlldir) {

25
src/racket/src/hash.c
View File

@ -1033,32 +1033,33 @@ XFORM_NONGCING static uintptr_t dbl_hash2_val(double d)
}
#ifdef MZ_LONG_DOUBLE
XFORM_NONGCING static uintptr_t long_dbl_hash_val(long double d)
XFORM_NONGCING static uintptr_t long_dbl_hash_val(long_double d)
XFORM_SKIP_PROC
{
int e;
if (MZ_IS_LONG_NAN(d)) {
d = 0.0L;
d = get_long_double_zero();
e = 1000;
} else if (MZ_IS_LONG_POS_INFINITY(d)) {
d = 0.5L;
d = get_long_double_one_half();
e = 1000;
} else if (MZ_IS_LONG_NEG_INFINITY(d)) {
d = -0.5L;
d = long_double_neg(get_long_double_one_half());
e = 1000;
} else if (!d && scheme_long_minus_zero_p(d)) {
d = 0L;
} else if (long_double_eqv(d, get_long_double_zero()) && scheme_long_minus_zero_p(d)) {
d = get_long_double_zero();
e = 1000;
} else {
/* frexpl should not be used on inf or nan: */
d = frexpl(d, &e);
d = long_double_frexp(d, &e);
}
return ((uintptr_t)(d * (1 << 30))) + e;
return uintptr_from_long_double(long_double_mult_i(d, 1<<30)) + e;
/*return ((uintptr_t)(d * (1 << 30))) + e;*/
}
XFORM_NONGCING static uintptr_t long_dbl_hash2_val(long double d)
XFORM_NONGCING static uintptr_t long_dbl_hash2_val(long_double d)
XFORM_SKIP_PROC
{
int e;
@ -1069,7 +1070,7 @@ XFORM_NONGCING static uintptr_t long_dbl_hash2_val(long double d)
e = 1;
} else {
/* frexp should not be used on inf or nan: */
d = frexpl(d, &e);
d = long_double_frexp(d, &e);
}
return to_unsigned_hash(e);
}
@ -1209,7 +1210,7 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi)
case scheme_extflvector_type:
{
intptr_t len = SCHEME_EXTFLVEC_SIZE(o), i;
long double d;
long_double d;
if (!len)
return k + 1;
@ -1676,7 +1677,7 @@ static uintptr_t equal_hash_key2(Scheme_Object *o, Hash_Info *hi)
case scheme_extflvector_type:
{
intptr_t len = SCHEME_EXTFLVEC_SIZE(o), i;
long double d;
long_double d;
uintptr_t k = 0;
if (!len)

4
src/racket/src/jit.c
View File

@ -3046,14 +3046,14 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
#ifdef MZ_LONG_DOUBLE
if (jitter->unbox_extflonum) {
long double d;
long_double d;
int fpr0;
if (SCHEME_LONG_DBLP(obj))
d = SCHEME_LONG_DBL_VAL(obj);
else {
bad = "ext";
d = 0.0L;
d = get_long_double_zero();
}
fpr0 = JIT_FPU_FPR_0(jitter->unbox_depth);

6
src/racket/src/jit.h
View File

@ -198,8 +198,8 @@ extern int scheme_jit_malloced;
THREAD_LOCAL_DECL(extern double scheme_jit_save_fp);
THREAD_LOCAL_DECL(extern double scheme_jit_save_fp2);
# ifdef MZ_LONG_DOUBLE
THREAD_LOCAL_DECL(extern long double scheme_jit_save_extfp);
THREAD_LOCAL_DECL(extern long double scheme_jit_save_extfp2);
THREAD_LOCAL_DECL(extern long_double scheme_jit_save_extfp);
THREAD_LOCAL_DECL(extern long_double scheme_jit_save_extfp2);
# endif
#endif
@ -1263,7 +1263,7 @@ int scheme_mz_compute_runstack_restored(mz_jit_state *jitter, int adj, int skip)
int scheme_mz_retain_it(mz_jit_state *jitter, void *v);
double *scheme_mz_retain_double(mz_jit_state *jitter, double d);
#ifdef MZ_LONG_DOUBLE
long double *scheme_mz_retain_long_double(mz_jit_state *jitter, long double d);
long_double *scheme_mz_retain_long_double(mz_jit_state *jitter, long_double d);
#endif
int scheme_mz_remap_it(mz_jit_state *jitter, int i);
void scheme_mz_pushr_p_it(mz_jit_state *jitter, int reg);

6
src/racket/src/jitalloc.c
View File

@ -45,8 +45,8 @@ THREAD_LOCAL_DECL(static void *retry_alloc_r1); /* set by prepare_retry_alloc()
THREAD_LOCAL_DECL(double scheme_jit_save_fp);
THREAD_LOCAL_DECL(double scheme_jit_save_fp2);
# ifdef MZ_LONG_DOUBLE
THREAD_LOCAL_DECL(long double scheme_jit_save_extfp);
THREAD_LOCAL_DECL(long double scheme_jit_save_extfp2);
THREAD_LOCAL_DECL(long_double scheme_jit_save_extfp);
THREAD_LOCAL_DECL(long_double scheme_jit_save_extfp2);
# endif
#endif
@ -296,7 +296,7 @@ Scheme_Object *scheme_jit_make_two_element_ivector(Scheme_Object *a, Scheme_Obje
#endif
#ifdef CAN_INLINE_ALLOC
long double ld1;
long_double ld1;
int scheme_generate_alloc_retry(mz_jit_state *jitter, int i)
{

33
src/racket/src/jitarith.c
View File

@ -662,13 +662,18 @@ static int generate_float_point_arith(mz_jit_state *jitter, Scheme_Object *rator
/* inexact->exact needs no extra number */
} else {
#ifdef MZ_LONG_DOUBLE
long double d = second_const;
long_double d;
d = long_double_from_int(second_const);
if (extfl) {
mz_fpu_movi_ld_fppush(fpr1, d, JIT_R2)
} else {
mz_movi_d_fppush(fpr1, second_const, JIT_R2);
}
#else
double d = second_const;
mz_movi_d_fppush(fpr1, d, JIT_R2);
#endif
MZ_FPUSEL_STMT(extfl,
mz_fpu_movi_ld_fppush(fpr1, d, JIT_R2),
mz_movi_d_fppush(fpr1, d, JIT_R2));
reversed = !reversed;
cmp = -cmp;
}
@ -696,6 +701,21 @@ static int generate_float_point_arith(mz_jit_state *jitter, Scheme_Object *rator
#endif
if (arith) {
#ifdef MZ_NEED_SET_EXTFL_MODE
int need_control_reset = 0;
if (extfl) {
switch (arith) {
case ARITH_ADD:
case ARITH_MUL:
case ARITH_DIV:
case ARITH_SUB:
case ARITH_SQRT:
jit_set_fp_control(0x37f);
need_control_reset = 1;
break;
}
}
#endif
switch (arith) {
case ARITH_ADD:
jit_FPSEL_addr_xd_fppop(extfl, fpr0, fpr0, fpr1);
@ -934,6 +954,11 @@ static int generate_float_point_arith(mz_jit_state *jitter, Scheme_Object *rator
}
#endif
}
#ifdef MZ_NEED_SET_EXTFL_MODE
if (extfl && need_control_reset) {
jit_set_fp_control(0x27f);
}
#endif
} else {
/* The "anti" variants below invert the branch. Unlike the "un"
variants, the "anti" variants invert the comparison result

10
src/racket/src/jitinline.c
View File

@ -2267,7 +2267,7 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE);
else {
MZ_FPUSEL_STMT(extfl,
jit_muli_ui(JIT_V1, JIT_V1, sizeof(long double)),
jit_muli_ui(JIT_V1, JIT_V1, sizeof(long_double)),
jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_DOUBLE_SIZE));
}
jit_addi_p(JIT_V1, JIT_V1, base_offset);
@ -3028,7 +3028,7 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
if (!which)
offset = base_offset + WORDS_TO_BYTES(offset);
else if (which == 3)
offset = base_offset + (offset * MZ_FPUSEL(extfl, sizeof(long double), sizeof(double)));
offset = base_offset + (offset * MZ_FPUSEL(extfl, sizeof(long_double), sizeof(double)));
else if (which == 1)
offset = offset << LOG_MZCHAR_SIZE;
jit_movi_l(JIT_V1, offset);
@ -3102,7 +3102,7 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
}
jit_rshi_ul(JIT_R1, JIT_R1, 1);
MZ_FPUSEL_STMT(extfl,
jit_muli_ui(JIT_R1, JIT_R1, sizeof(long double)),
jit_muli_ui(JIT_R1, JIT_R1, sizeof(long_double)),
jit_lshi_ul(JIT_R1, JIT_R1, JIT_LOG_DOUBLE_SIZE));
if (!is_f64) {
MZ_FPUSEL_STMT(extfl,
@ -3945,7 +3945,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
if (!which)
offset = base_offset + WORDS_TO_BYTES(offset);
else if (which == 3)
offset = base_offset + (offset * MZ_FPUSEL(extfl, sizeof(long double), sizeof(double)));
offset = base_offset + (offset * MZ_FPUSEL(extfl, sizeof(long_double), sizeof(double)));
else if (which == 1)
offset = offset << LOG_MZCHAR_SIZE;
else if ((which == 4) || (which == 5))
@ -4075,7 +4075,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
}
jit_rshi_ul(JIT_R1, JIT_R1, 1);
MZ_FPUSEL_STMT(extfl,
jit_muli_ui(JIT_R1, JIT_R1, sizeof(long double)),
jit_muli_ui(JIT_R1, JIT_R1, sizeof(long_double)),
jit_lshi_ul(JIT_R1, JIT_R1, JIT_LOG_DOUBLE_SIZE));
if (!is_f64) {
MZ_FPUSEL_STMT(extfl,

4
src/racket/src/jitstate.c
View File

@ -107,12 +107,12 @@ double *scheme_mz_retain_double(mz_jit_state *jitter, double d)
#endif
#ifdef MZ_LONG_DOUBLE
long double *scheme_mz_retain_long_double(mz_jit_state *jitter, long double ld)
long_double *scheme_mz_retain_long_double(mz_jit_state *jitter, long_double ld)
{
/* Save a long double into two cells of double */
void *p;
if (jitter->retain_start)
memcpy(&jitter->retain_double_start[jitter->retained_double], &ld, sizeof(long double));
memcpy(&jitter->retain_double_start[jitter->retained_double], &ld, sizeof(long_double));
p = jitter->retain_double_start + jitter->retained_double;
jitter->retained_double++;
jitter->retained_double++;

4
src/racket/src/lightning/i386/asm.h
View File

@ -1227,6 +1227,10 @@ typedef _uc jit_insn;
#define FNSTSWr(RD) ((RD == _AX || RD == _EAX) ? _OO (0xdfe0) \
: JITFAIL ("AX or EAX expected"))
#define FLDCWm(D, B, I, S) _O_r_X(0xd9, 5, D,B,I,S)
#define FNSTCWm(D, B, I, S) _O_r_X(0xd9, 7, D,B,I,S)
/* N byte NOPs */
#define NOPi(N) ((( (N) >= 8) ? (_jit_B(0x8d),_jit_B(0xb4),_jit_B(0x26),_jit_I(0x00),_jit_B(0x90)) : (void) 0), \
(( ((N)&7) == 7) ? (_jit_B(0x8d),_jit_B(0xb4),_jit_B(0x26),_jit_I(0x00)) : \

2
src/racket/src/lightning/i386/fp-extfpu.h
View File

@ -531,6 +531,7 @@ union jit_fpu_double_imm {
#define jit_fpu_pusharg_f(rs) (jit_fpu_subi_i(JIT_SP,JIT_SP,sizeof(float)), jit_fpu_str_f(JIT_SP,(rs)))
#define jit_fpu_retval_d(op1) jit_fpu_movr_d(0, (op1))
#define jit_set_fp_control(v) (PUSHWi(v), FLDCWm(0, JIT_SP, 0, 0), jit_addi_p(JIT_SP,JIT_SP,2))
#if 0
#define jit_sin() _OO(0xd9fe) /* fsin */
@ -555,5 +556,4 @@ union jit_fpu_double_imm {
_OO(0xd9f1)) /* fyl2x */
#endif
#endif

781
src/racket/src/longdouble/longdouble.c Normal file
View File

@ -0,0 +1,781 @@
#ifdef IMPLEMENTING_MSC_LONGDOUBLE
/* Implement the `long_double' API.
This code is meant to be compiled with MinGW gcc
to produce a DLL that is used by an MSVC-based
build. For a 32-bit build, use gcc v4.7.0 or later,
where the default handling of struct results matches
MSVC. */
#include <stdint.h>
#include "longdouble.h"
#include <math.h>
#include <stdio.h>
#include <string.h>
LDBL_DLL_API void set_x87_control(int v)
{
asm ("fldcw %0" : : "m" (v));
}
LDBL_DLL_API int get_x87_control()
{
int v;
asm ("fnstcw %0" : : "m" (v));
return v;
}
static void ext_mode()
{
set_x87_control(0x37F);
}
static void default_mode()
{
set_x87_control(0x27F);
}
long_double get_long_double_infinity_val()
{
long_double result;
ext_mode();
result.val = 1.0L / get_long_double_zero().val;
default_mode();
return result;
}
long_double get_long_double_minus_infinity_val()
{
long_double result;
ext_mode();
result.val = -get_long_double_infinity_val().val;
default_mode();
return result;
}
long_double get_long_double_zero()
{
long_double result;
ext_mode();
result.val = 0.0L;
default_mode();
return result;
}
long_double get_long_double_nzero()
{
long_double result;
ext_mode();
result.val = -1.0L / get_long_double_infinity_val().val;
default_mode();
return result;
}
long_double get_long_double_nan()
{
long_double result;
ext_mode();
result.val = get_long_double_infinity_val().val + get_long_double_minus_infinity_val().val;
default_mode();
return result;
}
long_double get_long_double_1()
{
long_double result;
ext_mode();
result.val = 1.0L;
default_mode();
return result;
}
long_double get_long_double_minus_1()
{
long_double result;
ext_mode();
result.val = -1.0L;
default_mode();
return result;
}
long_double get_long_double_2()
{
long_double result;
ext_mode();
result.val = 2.0L;
default_mode();
return result;
}
long_double get_long_double_one_half()
{
long_double result;
ext_mode();
result.val = 0.5L;
default_mode();
return result;
}
long_double get_long_double_pi()
{
long_double result;
ext_mode();
result.val = atan2l(0.0L, -1.0L);
default_mode();
return result;
}
long_double get_long_double_half_pi()
{
long_double result;
ext_mode();
result.val = atan2l(0.0L, -1.0L)/2.0L;
default_mode();
return result;
}
long_double long_double_from_int(int a)
{
long_double result;
ext_mode();
result.val = (long double) a;
default_mode();
return result;
}
long_double long_double_from_float(float a)
{
long_double result;
ext_mode();
result.val = (long double) a;
default_mode();
return result;
}
long_double long_double_from_double(double a)
{
long_double result;
ext_mode();
result.val = (long double) a;
default_mode();
return result;
}
long_double long_double_from_uintptr(uintptr_t a)
{
long_double result;
ext_mode();
result.val = a;
default_mode();
return result;
}
double double_from_long_double(long_double a)
{
return (double)a.val;
}
float float_from_long_double(long_double a)
{
return (float)a.val;
}
intptr_t int_from_long_double(long_double a)
{
return (intptr_t)a.val;
}
long_double long_double_plus(long_double a, long_double b)
{
long_double result;
ext_mode();
result.val = a.val + b.val;
default_mode();
return result;
}
long_double long_double_minus(long_double a, long_double b)
{
long_double result;
ext_mode();
result.val = a.val - b.val;
default_mode();
return result;
}
long_double long_double_mult(long_double a, long_double b)
{
long_double result;
ext_mode();
result.val = a.val * b.val;
default_mode();
return result;
}
long_double long_double_mult_i(long_double a, int b)
{
long_double result;
ext_mode();
result.val = a.val * b;
default_mode();
return result;
}
uintptr_t uintptr_from_long_double(long_double a)
{
uintptr_t result;
ext_mode();
result = a.val;
default_mode();
return result;
}
long_double long_double_div(long_double a, long_double b)
{
long_double result;
ext_mode();
result.val = a.val / b.val;
default_mode();
return result;
}
long_double long_double_neg(long_double a)
{
long_double result;
ext_mode();
result.val = -a.val;
default_mode();
return result;
}
int long_double_eqv(long_double a, long_double b)
{
return a.val == b.val;
}
int long_double_less(long_double a, long_double b)
{
return a.val < b.val;
}
int long_double_less_or_eqv(long_double a, long_double b)
{
return a.val <= b.val;
}
int long_double_greater(long_double a, long_double b)
{
return a.val > b.val;
}
int long_double_greater_or_eqv(long_double a, long_double b)
{
return a.val >= b.val;
}
int long_double_eqv_i(int a, long_double b)
{
return (long double) a == b.val;
}
int long_double_is_zero(long_double a)
{
return a.val == 0.0L;
}
int long_double_is_1(long_double a)
{
return a.val == 1.0L;
}
int long_double_minus_zero_p(long_double a)
{
int v;
ext_mode();
v = ((1.0L / a.val) < 0.0L);
default_mode();
return v;
}
int long_double_is_nan(long_double a)
{
return isnan(a.val);
}
int long_double_is_pos_infinity(long_double a)
{
return isinf(a.val) && a.val > 0;
}
int long_double_is_neg_infinity(long_double a)
{
return isinf(a.val) && a.val < 0;
}
int long_double_is_infinity(long_double a)
{
return isinf(a.val);
}
long_double long_double_fabs(long_double a)
{
long_double result;
ext_mode();
result.val = fabsl(a.val);
default_mode();
return result;
}
long_double long_double_modf(long_double a, long_double *b)
{
long_double result;
ext_mode();
result.val = modfl(a.val, &b->val);
default_mode();
return result;
}
long_double long_double_fmod(long_double a, long_double b)
{
long_double result;
ext_mode();
result.val = fmodl(a.val, b.val);
default_mode();
return result;
}
long_double long_double_trunc(long_double a)
{
long_double result;
ext_mode();
result.val = truncl(a.val);
default_mode();
return result;
}
long_double long_double_floor(long_double a)
{
long_double result;
ext_mode();
result.val = floorl(a.val);
default_mode();
return result;
}
long_double long_double_ceil(long_double a)
{
long_double result;
ext_mode();
result.val = ceill(a.val);
default_mode();
return result;
}
long_double long_double_sin(long_double a)
{
long_double result;
ext_mode();
result.val = sinl(a.val);
default_mode();
return result;
}
long_double long_double_cos(long_double a)
{
long_double result;
ext_mode();
result.val = cosl(a.val);
default_mode();
return result;
}
long_double long_double_tan(long_double a)
{
long_double result;
ext_mode();
result.val = tanl(a.val);
default_mode();
return result;
}
long_double long_double_asin(long_double a)
{
long_double result;
ext_mode();
result.val = asinl(a.val);
default_mode();
return result;
}
long_double long_double_acos(long_double a)
{
long_double result;
ext_mode();
result.val = acosl(a.val);
default_mode();
return result;
}
long_double long_double_atan(long_double a)
{
long_double result;
ext_mode();
result.val = atanl(a.val);
default_mode();
return result;
}
long_double long_double_log(long_double a)
{
long_double result;
ext_mode();
result.val = logl(a.val);
default_mode();
return result;
}
long_double long_double_exp(long_double a)
{
long_double result;
ext_mode();
result.val = expl(a.val);
default_mode();
return result;
}
long_double long_double_ldexp(long_double a, int i)
{
long_double result;
ext_mode();
result.val = ldexpl(a.val, i);
default_mode();
return result;
}
long_double long_double_pow(long_double a, long_double b)
{
long_double result;
ext_mode();
result.val = powl(a.val, b.val);
default_mode();
return result;
}
long_double long_double_sqrt(long_double a)
{
long_double result;
ext_mode();
result.val = sqrtl(a.val);
default_mode();
return result;
}
long_double long_double_frexp(long_double a, int* i)
{
long_double result;
ext_mode();
result.val = frexpl(a.val, i);
default_mode();
return result;
}
void long_double_sprint(char* buffer, int digits, long_double d)
{
ext_mode();
__mingw_sprintf(buffer, "%.*Lg", digits, d.val);
default_mode();
}
long_double long_double_array_ref(void *pointer, int index)
{
long_double result;
result = ((long_double *)pointer)[index];
return result;
}
void long_double_array_set(void *pointer, int index, long_double value)
{
((long_double *)pointer)[index] = value;
return ;
}
long_double long_double_from_string(char* buff, char** p)
{
long_double result;
char* ptr, one_char;
int n;
ext_mode();
n = __mingw_sscanf(buff, "%Lf%c", &result.val, &one_char);
default_mode();
if (n == 1) {
/* all characters consumed for the number */
*p = &buff[strlen(buff)];
} else {
/* didn't use the input string exactly;
pretend that no characters were consumed */
*p = buff;
}
return result;
}
#else
/* Glue code */
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
#endif
static int long_double_dll_available;
/* pointers to dynamically loaded functions */
#define DECLARE_LDBL(res, name, args) \
typedef res (* name ## _t)args; \
static name ## _t _imp_ ## name;
DECLARE_LDBL(long_double, get_long_double_infinity_val, ())
DECLARE_LDBL(long_double, get_long_double_minus_infinity_val, ())
DECLARE_LDBL(long_double, get_long_double_zero, ())
DECLARE_LDBL(long_double, get_long_double_nzero, ())
DECLARE_LDBL(long_double, get_long_double_nan, ())
DECLARE_LDBL(long_double, get_long_double_1, ())
DECLARE_LDBL(long_double, get_long_double_minus_1, ())
DECLARE_LDBL(long_double, get_long_double_2, ())
DECLARE_LDBL(long_double, get_long_double_one_half, ())
DECLARE_LDBL(long_double, get_long_double_pi, ())
DECLARE_LDBL(long_double, get_long_double_half_pi, ())
DECLARE_LDBL(void, set_long_double, (long_double a, long_double b))
DECLARE_LDBL(long_double, long_double_from_int, (int a))
DECLARE_LDBL(long_double, long_double_from_float, (float a))
DECLARE_LDBL(long_double, long_double_from_double, (double a))
DECLARE_LDBL(long_double, long_double_from_uintptr, (uintptr_t a))
DECLARE_LDBL(double, double_from_long_double, (long_double a))
DECLARE_LDBL(float, float_from_long_double, (long_double a))
DECLARE_LDBL(intptr_t, int_from_long_double, (long_double a))
DECLARE_LDBL(uintptr_t, uintptr_from_long_double, (long_double a))
DECLARE_LDBL(long_double, long_double_plus, (long_double a, long_double b))
DECLARE_LDBL(long_double, long_double_minus, (long_double a, long_double b))
DECLARE_LDBL(long_double, long_double_mult, (long_double a, long_double b))
DECLARE_LDBL(long_double, long_double_mult_i, (long_double a, int b))
DECLARE_LDBL(long_double, long_double_div, (long_double a, long_double b))
DECLARE_LDBL(long_double, long_double_neg, (long_double a))
DECLARE_LDBL(int, long_double_eqv, (long_double a, long_double b))
DECLARE_LDBL(int, long_double_less, (long_double a, long_double b))
DECLARE_LDBL(int, long_double_less_or_eqv, (long_double a, long_double b))
DECLARE_LDBL(int, long_double_greater, (long_double a, long_double b))
DECLARE_LDBL(int, long_double_greater_or_eqv, (long_double a, long_double b))
DECLARE_LDBL(int, long_double_eqv_i, (int a, long_double b))
DECLARE_LDBL(int, long_double_is_zero, (long_double a))
DECLARE_LDBL(int, long_double_is_1, (long_double a))
DECLARE_LDBL(int, long_double_minus_zero_p, (long_double a))
DECLARE_LDBL(int, long_double_is_nan, (long_double a))
DECLARE_LDBL(int, long_double_is_pos_infinity, (long_double a))
DECLARE_LDBL(int, long_double_is_neg_infinity, (long_double a))
DECLARE_LDBL(int, long_double_is_infinity, (long_double a))
DECLARE_LDBL(long_double, long_double_fabs, (long_double a))
DECLARE_LDBL(long_double, long_double_modf, (long_double a, long_double *b))
DECLARE_LDBL(long_double, long_double_fmod, (long_double a, long_double b))
DECLARE_LDBL(long_double, long_double_trunc, (long_double a))
DECLARE_LDBL(long_double, long_double_floor, (long_double a))
DECLARE_LDBL(long_double, long_double_ceil, (long_double a))
DECLARE_LDBL(long_double, long_double_sin, (long_double a))
DECLARE_LDBL(long_double, long_double_cos, (long_double a))
DECLARE_LDBL(long_double, long_double_tan, (long_double a))
DECLARE_LDBL(long_double, long_double_asin, (long_double a))
DECLARE_LDBL(long_double, long_double_acos, (long_double a))
DECLARE_LDBL(long_double, long_double_atan, (long_double a))
DECLARE_LDBL(long_double, long_double_log, (long_double a))
DECLARE_LDBL(long_double, long_double_exp, (long_double a))
DECLARE_LDBL(long_double, long_double_ldexp, (long_double a, int i))
DECLARE_LDBL(long_double, long_double_pow, (long_double a, long_double b))
DECLARE_LDBL(long_double, long_double_sqrt, (long_double a))
DECLARE_LDBL(long_double, long_double_frexp, (long_double a, int* i))
DECLARE_LDBL(void, long_double_sprint, (char* buffer, int digits, long_double d))
DECLARE_LDBL(long_double, long_double_array_ref, (void *pointer, int index))
DECLARE_LDBL(void, long_double_array_set, (void *pointer, int index, long_double value))
DECLARE_LDBL(long_double, long_double_from_string, (char* buff, char** p))
DECLARE_LDBL(void, set_x87_control, (int v))
DECLARE_LDBL(int, get_x87_control, ())
static long_double fail_long_double() {
long_double d;
memset(&d, 0, sizeof(d));
return d;
}
static int fail_int() { return 0; }
static void fail_void() { }
static double fail_double() { return 0.0; }
static float fail_float() { return 0.0; }
static uintptr_t fail_uintptr() { return 0; }
/* If "longdouble.dll" is not available, then fall back to `double'
parsing and printing, so that we can at least implement reading
and printing (which are supposed to always work). */
static long_double fail_from_string(char* buff, char** p)
{
double d;
long_double ld;
d = strtod(buff, p, 0);
memcpy(&ld, &d, sizeof(double));
return ld;
}
static void fail_sprint(char* buffer, int digits, long_double ld)
{
double d;
memcpy(&d, &ld, sizeof(double));
sprintf(buffer, "%.*Lg", digits, d);
}
/* initialization */
void scheme_load_long_double_dll()
{
HANDLE m;
m = LoadLibraryW(scheme_get_dll_path(L"longdouble.dll"));
if (m) long_double_dll_available = 1;
# define EXTRACT_LDBL(name, fail) \
_imp_ ## name = (name ##_t)(m ? GetProcAddress(m, # name) : NULL); \
if (!(_imp_ ## name)) _imp_ ## name = (name ##_t)fail;
EXTRACT_LDBL(get_long_double_infinity_val, fail_long_double);
EXTRACT_LDBL(get_long_double_minus_infinity_val, fail_long_double);
EXTRACT_LDBL(get_long_double_zero, fail_long_double);
EXTRACT_LDBL(get_long_double_nzero, fail_long_double);
EXTRACT_LDBL(get_long_double_nan, fail_long_double);
EXTRACT_LDBL(get_long_double_1, fail_long_double);
EXTRACT_LDBL(get_long_double_minus_1, fail_long_double);
EXTRACT_LDBL(get_long_double_2, fail_long_double);
EXTRACT_LDBL(get_long_double_one_half, fail_long_double);
EXTRACT_LDBL(get_long_double_pi, fail_long_double);
EXTRACT_LDBL(get_long_double_half_pi, fail_long_double);
EXTRACT_LDBL(set_long_double, fail_void);
EXTRACT_LDBL(long_double_from_int, fail_long_double);
EXTRACT_LDBL(long_double_from_float, fail_long_double);
EXTRACT_LDBL(long_double_from_double, fail_long_double);
EXTRACT_LDBL(long_double_from_uintptr, fail_long_double);
EXTRACT_LDBL(double_from_long_double, fail_double);
EXTRACT_LDBL(float_from_long_double, fail_float);
EXTRACT_LDBL(int_from_long_double, fail_int);
EXTRACT_LDBL(uintptr_from_long_double, fail_uintptr);
EXTRACT_LDBL(long_double_plus, fail_long_double);
EXTRACT_LDBL(long_double_minus, fail_long_double);
EXTRACT_LDBL(long_double_mult, fail_long_double);
EXTRACT_LDBL(long_double_mult_i, fail_long_double);
EXTRACT_LDBL(long_double_div, fail_long_double);
EXTRACT_LDBL(long_double_neg, fail_long_double);
EXTRACT_LDBL(long_double_eqv, fail_int);
EXTRACT_LDBL(long_double_less, fail_int);
EXTRACT_LDBL(long_double_less_or_eqv, fail_int);
EXTRACT_LDBL(long_double_greater, fail_int);
EXTRACT_LDBL(long_double_greater_or_eqv, fail_int);
EXTRACT_LDBL(long_double_eqv_i, fail_int);
EXTRACT_LDBL(long_double_is_zero, fail_int);
EXTRACT_LDBL(long_double_is_1, fail_int);
EXTRACT_LDBL(long_double_minus_zero_p, fail_int);
EXTRACT_LDBL(long_double_is_nan, fail_int);
EXTRACT_LDBL(long_double_is_pos_infinity, fail_int);
EXTRACT_LDBL(long_double_is_neg_infinity, fail_int);
EXTRACT_LDBL(long_double_is_infinity, fail_int);
EXTRACT_LDBL(long_double_fabs, fail_long_double);
EXTRACT_LDBL(long_double_modf, fail_long_double);
EXTRACT_LDBL(long_double_fmod, fail_long_double);
EXTRACT_LDBL(long_double_trunc, fail_long_double);
EXTRACT_LDBL(long_double_floor, fail_long_double);
EXTRACT_LDBL(long_double_ceil, fail_long_double);
EXTRACT_LDBL(long_double_sin, fail_long_double);
EXTRACT_LDBL(long_double_cos, fail_long_double);
EXTRACT_LDBL(long_double_tan, fail_long_double);
EXTRACT_LDBL(long_double_asin, fail_long_double);
EXTRACT_LDBL(long_double_acos, fail_long_double);
EXTRACT_LDBL(long_double_atan, fail_long_double);
EXTRACT_LDBL(long_double_log, fail_long_double);
EXTRACT_LDBL(long_double_exp, fail_long_double);
EXTRACT_LDBL(long_double_ldexp, fail_long_double);
EXTRACT_LDBL(long_double_pow, fail_long_double);
EXTRACT_LDBL(long_double_sqrt, fail_long_double);
EXTRACT_LDBL(long_double_frexp, fail_long_double);
EXTRACT_LDBL(long_double_sprint, fail_sprint);
EXTRACT_LDBL(long_double_array_ref, fail_long_double);
EXTRACT_LDBL(long_double_array_set, fail_void);
EXTRACT_LDBL(long_double_from_string, fail_from_string);
EXTRACT_LDBL(set_x87_control, fail_void);
EXTRACT_LDBL(get_x87_control, fail_int);
}
int long_double_available() {
return long_double_dll_available;
}
/* Glue functions */
long_double get_long_double_infinity_val() { return _imp_get_long_double_infinity_val(); }
long_double get_long_double_minus_infinity_val() { return _imp_get_long_double_minus_infinity_val(); }
long_double get_long_double_zero() { return _imp_get_long_double_zero(); }
long_double get_long_double_nzero() { return _imp_get_long_double_nzero(); }
long_double get_long_double_nan() { return _imp_get_long_double_nan(); }
long_double get_long_double_1() { return _imp_get_long_double_1(); }
long_double get_long_double_minus_1() { return _imp_get_long_double_minus_1(); }
long_double get_long_double_2() { return _imp_get_long_double_2(); }
long_double get_long_double_one_half() { return _imp_get_long_double_one_half(); }
long_double get_long_double_pi() { return _imp_get_long_double_pi(); }
long_double get_long_double_half_pi() { return _imp_get_long_double_half_pi(); }
void set_long_double(long_double a, long_double b) { _imp_set_long_double(a, b); }
long_double long_double_from_int(int a) { return _imp_long_double_from_int(a); }
long_double long_double_from_float(float a) { return _imp_long_double_from_float(a); }
long_double long_double_from_double(double a) { return _imp_long_double_from_double(a); }
long_double long_double_from_uintptr(uintptr_t a) { return _imp_long_double_from_uintptr(a); }
double double_from_long_double(long_double a) { return _imp_double_from_long_double(a); }
float float_from_long_double(long_double a) { return _imp_float_from_long_double(a); }
intptr_t int_from_long_double(long_double a) { return _imp_int_from_long_double(a); }
uintptr_t uintptr_from_long_double(long_double a) { return _imp_uintptr_from_long_double(a); }
long_double long_double_plus(long_double a, long_double b) { return _imp_long_double_plus(a, b); }
long_double long_double_minus(long_double a, long_double b) { return _imp_long_double_minus(a, b); }
long_double long_double_mult(long_double a, long_double b) { return _imp_long_double_mult(a, b); }
long_double long_double_mult_i(long_double a, int b) { return _imp_long_double_mult_i(a, b); }
long_double long_double_div(long_double a, long_double b) { return _imp_long_double_div(a, b); }
long_double long_double_neg(long_double a) { return _imp_long_double_neg(a); }
int long_double_eqv(long_double a, long_double b) { return _imp_long_double_eqv(a, b); }
int long_double_less(long_double a, long_double b) { return _imp_long_double_less(a, b); }
int long_double_less_or_eqv(long_double a, long_double b) { return _imp_long_double_less_or_eqv(a, b); }
int long_double_greater(long_double a, long_double b) { return _imp_long_double_greater(a, b); }
int long_double_greater_or_eqv(long_double a, long_double b) { return _imp_long_double_greater_or_eqv(a, b); }
int long_double_eqv_i(int a, long_double b) { return _imp_long_double_eqv_i(a, b); }
int long_double_is_zero(long_double a) { return _imp_long_double_is_zero(a); }
int long_double_is_1(long_double a) { return _imp_long_double_is_1(a); }
int long_double_minus_zero_p(long_double a) { return _imp_long_double_minus_zero_p(a); }
int long_double_is_nan(long_double a) { return _imp_long_double_is_nan(a); }
int long_double_is_pos_infinity(long_double a) { return _imp_long_double_is_pos_infinity(a); }
int long_double_is_neg_infinity(long_double a) { return _imp_long_double_is_neg_infinity(a); }
int long_double_is_infinity(long_double a) { return _imp_long_double_is_infinity(a); }
long_double long_double_fabs(long_double a) { return _imp_long_double_fabs(a); }
long_double long_double_modf(long_double a, long_double *b) { return _imp_long_double_modf(a, b); }
long_double long_double_fmod(long_double a, long_double b) { return _imp_long_double_fmod(a, b); }
long_double long_double_trunc(long_double a) { return _imp_long_double_trunc(a); }
long_double long_double_floor(long_double a) { return _imp_long_double_floor(a); }
long_double long_double_ceil(long_double a) { return _imp_long_double_ceil(a); }
long_double long_double_sin(long_double a) { return _imp_long_double_sin(a); }
long_double long_double_cos(long_double a) { return _imp_long_double_cos(a); }
long_double long_double_tan(long_double a) { return _imp_long_double_tan(a); }
long_double long_double_asin(long_double a) { return _imp_long_double_asin(a); }
long_double long_double_acos(long_double a) { return _imp_long_double_acos(a); }
long_double long_double_atan(long_double a) { return _imp_long_double_atan(a); }
long_double long_double_log(long_double a) { return _imp_long_double_log(a); }
long_double long_double_exp(long_double a) { return _imp_long_double_exp(a); }
long_double long_double_ldexp(long_double a, int i) { return _imp_long_double_ldexp(a, i); }
long_double long_double_pow(long_double a, long_double b) { return _imp_long_double_pow(a, b); }
long_double long_double_sqrt(long_double a) { return _imp_long_double_sqrt(a); }
long_double long_double_frexp(long_double a, int* i) { return _imp_long_double_frexp(a, i); }
void long_double_sprint(char* buffer, int digits, long_double d) { _imp_long_double_sprint(buffer, digits, d); }
long_double long_double_array_ref(void *pointer, int index) { return _imp_long_double_array_ref(pointer, index); }
void long_double_array_set(void *pointer, int index, long_double value) { _imp_long_double_array_set(pointer, index, value); }
long_double long_double_from_string(char* buff, char** p) { return _imp_long_double_from_string(buff, p); }
void to_double_prec() { _imp_set_x87_control(0x27F); }
void to_extended_prec() { _imp_set_x87_control(0x37F); }
#ifdef MZ_PRECISE_GC
END_XFORM_SKIP;
#endif
#endif

213
src/racket/src/longdouble/longdouble.h Normal file
View File

@ -0,0 +1,213 @@
#ifndef MZ_LONGDOUBLE_H
#define MZ_LONGDOUBLE_H
#if defined(_MSC_VER) || defined(IMPLEMENTING_MSC_LONGDOUBLE)
/* aligning */
# if defined(_X86_64) || defined(_M_X64) || defined(_WIN64)
# define SIZEOF_LONGDOUBLE 16
# else
# define SIZEOF_LONGDOUBLE 16
# endif
# ifdef BYTES_RESERVED_FOR_LONG_DOUBLE
/* check "scheme.h" versus "longdouble.h": */
# if BYTES_RESERVED_FOR_LONG_DOUBLE != SIZEOF_LONGDOUBLE
!! mismatch in mz_long_double size !!
# endif
# endif
# ifdef IMPLEMENTING_MSC_LONGDOUBLE
typedef union long_double
{
char bytes[SIZEOF_LONGDOUBLE];
long double val;
} long_double;
# else
# define long_double mz_long_double
# endif
#else
# define long_double mz_long_double
#endif
#ifdef IMPLEMENTING_MSC_LONGDOUBLE
# define LDBL_DLL_API __declspec(dllexport)
# define XFORM_NONGCING /* empty */
#else
# define LDBL_DLL_API /* empty */
#endif
#if defined(_MSC_VER) || defined(IMPLEMENTING_MSC_LONGDOUBLE)
#define MZ_LONG_DOUBLE_API_IS_EXTERNAL
void scheme_load_long_double_dll();
XFORM_NONGCING LDBL_DLL_API long_double get_long_double_infinity_val();
XFORM_NONGCING LDBL_DLL_API long_double get_long_double_minus_infinity_val();
XFORM_NONGCING LDBL_DLL_API long_double get_long_double_zero();
XFORM_NONGCING LDBL_DLL_API long_double get_long_double_nzero();
XFORM_NONGCING LDBL_DLL_API long_double get_long_double_nan();
XFORM_NONGCING LDBL_DLL_API long_double get_long_double_1();
XFORM_NONGCING LDBL_DLL_API long_double get_long_double_minus_1();
XFORM_NONGCING LDBL_DLL_API long_double get_long_double_2();
XFORM_NONGCING LDBL_DLL_API long_double get_long_double_one_half();
XFORM_NONGCING LDBL_DLL_API long_double get_long_double_pi();
XFORM_NONGCING LDBL_DLL_API long_double get_long_double_half_pi();
XFORM_NONGCING LDBL_DLL_API void set_long_double(long_double a, long_double b);
XFORM_NONGCING LDBL_DLL_API long_double long_double_from_int(int a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_from_float(float a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_from_double(double a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_from_uintptr(uintptr_t a);
XFORM_NONGCING LDBL_DLL_API double double_from_long_double(long_double a);
XFORM_NONGCING LDBL_DLL_API float float_from_long_double(long_double a);
XFORM_NONGCING LDBL_DLL_API intptr_t int_from_long_double(long_double a);
XFORM_NONGCING LDBL_DLL_API uintptr_t uintptr_from_long_double(long_double a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_plus(long_double a, long_double b);
XFORM_NONGCING LDBL_DLL_API long_double long_double_minus(long_double a, long_double b);
XFORM_NONGCING LDBL_DLL_API long_double long_double_mult(long_double a, long_double b);
XFORM_NONGCING LDBL_DLL_API long_double long_double_mult_i(long_double a, int b);
XFORM_NONGCING LDBL_DLL_API long_double long_double_div(long_double a, long_double b);
XFORM_NONGCING LDBL_DLL_API long_double long_double_neg(long_double a);
XFORM_NONGCING LDBL_DLL_API int long_double_eqv(long_double a, long_double b);
XFORM_NONGCING LDBL_DLL_API int long_double_less(long_double a, long_double b);
XFORM_NONGCING LDBL_DLL_API int long_double_less_or_eqv(long_double a, long_double b);
XFORM_NONGCING LDBL_DLL_API int long_double_greater(long_double a, long_double b);
XFORM_NONGCING LDBL_DLL_API int long_double_greater_or_eqv(long_double a, long_double b);
XFORM_NONGCING LDBL_DLL_API int long_double_eqv_i(int a, long_double b);
XFORM_NONGCING LDBL_DLL_API int long_double_is_zero(long_double a);
XFORM_NONGCING LDBL_DLL_API int long_double_is_1(long_double a);
XFORM_NONGCING LDBL_DLL_API int long_double_minus_zero_p(long_double a);
XFORM_NONGCING LDBL_DLL_API int long_double_is_nan(long_double a);
XFORM_NONGCING LDBL_DLL_API int long_double_is_pos_infinity(long_double a);
XFORM_NONGCING LDBL_DLL_API int long_double_is_neg_infinity(long_double a);
XFORM_NONGCING LDBL_DLL_API int long_double_is_infinity(long_double a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_fabs(long_double a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_modf(long_double a, long_double *b);
XFORM_NONGCING LDBL_DLL_API long_double long_double_fmod(long_double a, long_double b);
XFORM_NONGCING LDBL_DLL_API long_double long_double_trunc(long_double a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_floor(long_double a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_ceil(long_double a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_sin(long_double a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_cos(long_double a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_tan(long_double a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_asin(long_double a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_acos(long_double a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_atan(long_double a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_log(long_double a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_exp(long_double a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_ldexp(long_double a, int i);
XFORM_NONGCING LDBL_DLL_API long_double long_double_pow(long_double a, long_double b);
XFORM_NONGCING LDBL_DLL_API long_double long_double_sqrt(long_double a);
XFORM_NONGCING LDBL_DLL_API long_double long_double_frexp(long_double a, int* i);
XFORM_NONGCING LDBL_DLL_API void long_double_sprint(char* buffer, int digits, long_double d);
XFORM_NONGCING LDBL_DLL_API long_double long_double_array_ref(void *pointer, int index);
XFORM_NONGCING LDBL_DLL_API void long_double_array_set(void *pointer, int index, long_double value);
XFORM_NONGCING LDBL_DLL_API long_double long_double_from_string(char* buff, char** p);
XFORM_NONGCING void to_double_prec();
XFORM_NONGCING void to_extended_prec();
XFORM_NONGCING int long_double_available();
#else
# define get_long_double_infinity_val() 1.0L/0.0L
# define get_long_double_minus_infinity_val() -1.0L/0.0L
# define get_long_double_zero() 0.0L
# define get_long_double_nzero() (0.0L*(-1.0L))
# define get_long_double_nan() get_long_double_infinity_val() + get_long_double_minus_infinity_val()
# define get_long_double_1() 1.0L
# define get_long_double_minus_1() (-1.0L)
# define get_long_double_2() 2.0L
# define get_long_double_one_half() 0.5L
# define get_long_double_pi() atan2l(0.0L, -1.0L)
# define get_long_double_half_pi() atan2l(0.0L, -1.0L)/2.0L
# define long_double_from_int(a) ((long double)(a))
# define long_double_from_float(a) ((long double)(a))
# define long_double_from_double(a) ((long double)(a))
# define long_double_from_uintptr(a) ((long double)(a))
# define double_from_long_double(a) (a)
# define float_from_long_double(a) (a)
# define int_from_long_double(a) ((int)(a))
# define uintptr_from_long_double(a) ((uintptr_t)(a))
# define long_double_plus(a,b) ((a)+(b))
# define long_double_minus(a,b) ((a)-(b))
# define long_double_mult(a,b) ((a)*(b))
# define long_double_div(a,b) ((a)/(b))
# define long_double_neg(x) (-(x))
# define long_double_mult_i(a,b) ((a)*(b))
# define long_double_eqv(a,b) ((a)==(b))
# define long_double_less(a,b) ((a)<(b))
# define long_double_less_or_eqv(a,b) ((a)<=(b))
# define long_double_greater(a,b) ((a)>(b))
# define long_double_greater_or_eqv(a,b) ((a)>=(b))
# define long_double_eqv_i(a,b) ((long double)(a) == (b))
# define long_double_is_zero(a) ((a) == 0.0L)
# define long_double_is_1(a) ((a) == 1.0L)
# define long_double_minus_zero_p(a) ((1.0L/(a)) < 0.0L)
# define long_double_is_nan(a) (isnan(a))
# define long_double_is_pos_infinity(a) (isinf(a)&&((a)>0))
# define long_double_is_neg_infinity(a) (isinf(a)&&((a)<0))
# define long_double_is_infinity(a) (isinf(a))
# define long_double_fabs(a) fabsl(a)
# define long_double_modf(a,b) modfl(a,b)
# define long_double_fmod(a,b) fmodl(a,b)
# define long_double_trunc(a) truncl(a)
# define long_double_floor(a) floorl(a)
# define long_double_ceil(a) ceill(a)
# define long_double_sin(x) sinl(x)
# define long_double_cos(x) cosl(x)
# define long_double_tan(x) tanl(x)
# define long_double_asin(x) asinl(x)
# define long_double_acos(x) acosl(x)
# define long_double_atan(x) atanl(x)
# define long_double_log(x) logl(x)
# define long_double_exp(x) expl(x)
# define long_double_ldexp(a, i) ldexpl(a, i)
# define long_double_pow(x,y) powl(x, y)
# define long_double_sqrt(a) sqrtl(a)
# define long_double_frexp(a, i) frexpl(a, i)
# define long_double_from_string(x,y) strtold(x, y)
# define long_double_sprint(buffer,digits,d) sprintf(buffer, "%.*Lg", digits, d)
# define long_double_array_ref(pointer,index) ((long_double *)(pointer))[index]
# define long_double_array_set(pointer,index,value) ((long_double *)(pointer))[index] = (value)
# define long_double_available() 1
#endif
#endif // MZ_LONGDOUBLE_H

62
src/racket/src/numarith.c
View File

@ -252,7 +252,7 @@ void scheme_init_extfl_numarith(Scheme_Env *env)
int flags;
p = scheme_make_folding_prim(extfl_plus, "extfl+", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -262,7 +262,7 @@ void scheme_init_extfl_numarith(Scheme_Env *env)
scheme_add_global_constant("extfl+", p, env);
p = scheme_make_folding_prim(extfl_minus, "extfl-", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -272,7 +272,7 @@ void scheme_init_extfl_numarith(Scheme_Env *env)
scheme_add_global_constant("extfl-", p, env);
p = scheme_make_folding_prim(extfl_mult, "extfl*", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -282,7 +282,7 @@ void scheme_init_extfl_numarith(Scheme_Env *env)
scheme_add_global_constant("extfl*", p, env);
p = scheme_make_folding_prim(extfl_div, "extfl/", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -292,7 +292,7 @@ void scheme_init_extfl_numarith(Scheme_Env *env)
scheme_add_global_constant("extfl/", p, env);
p = scheme_make_folding_prim(extfl_abs, "extflabs", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -302,7 +302,7 @@ void scheme_init_extfl_numarith(Scheme_Env *env)
scheme_add_global_constant("extflabs", p, env);
p = scheme_make_folding_prim(extfl_sqrt, "extflsqrt", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -433,7 +433,7 @@ void scheme_init_extfl_unsafe_numarith(Scheme_Env *env)
int flags;
p = scheme_make_folding_prim(unsafe_extfl_plus, "unsafe-extfl+", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -444,7 +444,7 @@ void scheme_init_extfl_unsafe_numarith(Scheme_Env *env)
scheme_add_global_constant("unsafe-extfl+", p, env);
p = scheme_make_folding_prim(unsafe_extfl_minus, "unsafe-extfl-", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -455,7 +455,7 @@ void scheme_init_extfl_unsafe_numarith(Scheme_Env *env)
scheme_add_global_constant("unsafe-extfl-", p, env);
p = scheme_make_folding_prim(unsafe_extfl_mult, "unsafe-extfl*", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -466,7 +466,7 @@ void scheme_init_extfl_unsafe_numarith(Scheme_Env *env)
scheme_add_global_constant("unsafe-extfl*", p, env);
p = scheme_make_folding_prim(unsafe_extfl_div, "unsafe-extfl/", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -477,7 +477,7 @@ void scheme_init_extfl_unsafe_numarith(Scheme_Env *env)
scheme_add_global_constant("unsafe-extfl/", p, env);
p = scheme_make_folding_prim(unsafe_extfl_abs, "unsafe-extflabs", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -488,7 +488,7 @@ void scheme_init_extfl_unsafe_numarith(Scheme_Env *env)
scheme_add_global_constant("unsafe-extflabs", p, env);
p = scheme_make_folding_prim(unsafe_extfl_sqrt, "unsafe-extflsqrt", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1293,8 +1293,9 @@ SAFE_FL1(fl_sqrt, "flsqrt", sqrt)
# define UNSAFE_EXTFL(name, op) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
long double v; \
v = SCHEME_LONG_DBL_VAL(argv[0]) op SCHEME_LONG_DBL_VAL(argv[1]); \
long_double v; \
CHECK_MZ_LONG_DOUBLE_UNSUPPORTED("unsafe-extfl" #op); \
v = op(SCHEME_LONG_DBL_VAL(argv[0]), SCHEME_LONG_DBL_VAL(argv[1])); \
return scheme_make_long_double(v); \
}
#else
@ -1307,16 +1308,16 @@ SAFE_FL1(fl_sqrt, "flsqrt", sqrt)
}
#endif
UNSAFE_EXTFL(unsafe_extfl_plus, +)
UNSAFE_EXTFL(unsafe_extfl_minus, -)
UNSAFE_EXTFL(unsafe_extfl_mult, *)
UNSAFE_EXTFL(unsafe_extfl_div, /)
UNSAFE_EXTFL(unsafe_extfl_plus, long_double_plus)
UNSAFE_EXTFL(unsafe_extfl_minus, long_double_minus)
UNSAFE_EXTFL(unsafe_extfl_mult, long_double_mult)
UNSAFE_EXTFL(unsafe_extfl_div, long_double_div)
#ifdef MZ_LONG_DOUBLE
# define UNSAFE_EXTFL1(name, op) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
long double v; \
long_double v; \
v = SCHEME_LONG_DBL_VAL(argv[0]); \
v = op(v); \
return scheme_make_long_double(v); \
@ -1325,17 +1326,18 @@ UNSAFE_EXTFL(unsafe_extfl_div, /)
# define UNSAFE_EXTFL1(name, op) UNSAFE_EXTFL(name, op)
#endif
UNSAFE_EXTFL1(unsafe_extfl_abs, fabsl)
UNSAFE_EXTFL1(unsafe_extfl_sqrt, sqrtl)
UNSAFE_EXTFL1(unsafe_extfl_abs, long_double_fabs)
UNSAFE_EXTFL1(unsafe_extfl_sqrt, long_double_sqrt)
#ifdef MZ_LONG_DOUBLE
# define SAFE_EXTFL(name, sname, op) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
long double v; \
long_double v; \
CHECK_MZ_LONG_DOUBLE_UNSUPPORTED(sname); \
if (!SCHEME_LONG_DBLP(argv[0])) scheme_wrong_contract(sname, "extflonum?", 0, argc, argv); \
if (!SCHEME_LONG_DBLP(argv[1])) scheme_wrong_contract(sname, "extflonum?", 1, argc, argv); \
v = SCHEME_LONG_DBL_VAL(argv[0]) op SCHEME_LONG_DBL_VAL(argv[1]); \
v = op(SCHEME_LONG_DBL_VAL(argv[0]), SCHEME_LONG_DBL_VAL(argv[1])); \
return scheme_make_long_double(v); \
}
#else
@ -1348,16 +1350,16 @@ UNSAFE_EXTFL1(unsafe_extfl_sqrt, sqrtl)
}
#endif
SAFE_EXTFL(extfl_plus, "extfl+", +)
SAFE_EXTFL(extfl_minus, "extfl-", -)
SAFE_EXTFL(extfl_mult, "extfl*", *)
SAFE_EXTFL(extfl_div, "extfl/", /)
SAFE_EXTFL(extfl_plus, "extfl+", long_double_plus)
SAFE_EXTFL(extfl_minus, "extfl-", long_double_minus)
SAFE_EXTFL(extfl_mult, "extfl*", long_double_mult)
SAFE_EXTFL(extfl_div, "extfl/", long_double_div)
#ifdef MZ_LONG_DOUBLE
# define SAFE_EXTFL1(name, sname, op) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
long double v; \
long_double v; \
if (!SCHEME_LONG_DBLP(argv[0])) scheme_wrong_contract(sname, "extflonum?", 0, argc, argv); \
v = SCHEME_LONG_DBL_VAL(argv[0]); \
v = op(v); \
@ -1367,5 +1369,5 @@ SAFE_EXTFL(extfl_div, "extfl/", /)
# define SAFE_EXTFL1(name, sname, op) SAFE_EXTFL(name, sname, op)
#endif
SAFE_EXTFL1(extfl_abs, "extflabs", fabs)
SAFE_EXTFL1(extfl_sqrt, "extflsqrt", sqrt)
SAFE_EXTFL1(extfl_abs, "extflabs", long_double_fabs)
SAFE_EXTFL1(extfl_sqrt, "extflsqrt", long_double_sqrt)

361
src/racket/src/number.c
View File

@ -25,6 +25,7 @@
#include "schpriv.h"
#include "nummacs.h"
#include "longdouble/longdouble.h"
#include <math.h>
#include <string.h>
#include <ctype.h>
@ -234,12 +235,12 @@ READ_ONLY Scheme_Object *scheme_single_inf_object, *scheme_single_minus_inf_obje
#endif
#ifdef MZ_LONG_DOUBLE
READ_ONLY long double scheme_long_infinity_val;
READ_ONLY long double scheme_long_minus_infinity_val;
READ_ONLY long double scheme_long_floating_point_zero = 0.0L;
READ_ONLY long double scheme_long_floating_point_nzero = 0.0L; /* negated below; many compilers treat -0.0 as 0.0,
READ_ONLY long_double scheme_long_infinity_val;
READ_ONLY long_double scheme_long_minus_infinity_val;
READ_ONLY long_double scheme_long_floating_point_zero;
READ_ONLY long_double scheme_long_floating_point_nzero; /* negated below; many compilers treat -0.0 as 0.0,
but otherwise correctly implement fp negation */
READ_ONLY static long double long_not_a_number_val;
READ_ONLY static long_double long_not_a_number_val;
READ_ONLY Scheme_Object *scheme_long_inf_object, *scheme_long_minus_inf_object, *scheme_long_nan_object;
@ -271,8 +272,8 @@ static void to_double_prec(void)
#if defined(ASM_DBLPREC_CONTROL_87) || defined(ASM_EXTPREC_CONTROL_87)
static void to_extended_prec(void)
{
int _dblprec = 0x37F;
asm ("fldcw %0" : : "m" (_dblprec));
int _extprec = 0x37F;
asm ("fldcw %0" : : "m" (_extprec));
}
#endif
@ -301,6 +302,13 @@ void scheme_configure_floating_point(void)
should do this, but explicitly masking exceptions
makes Racket work under Bochs 2.1.1 with Win95 */
_control87(_MCW_EM, _MCW_EM);
/* When MZ_LONG_DOUBLE is defined, it might make sense
to try to put the processor in extended-precision
mode, but control87() seems to disallow that, and
library functions seem to reset the mode, anyway.
So, we set and restore the mode as needed in
the "longdouble.c"-based DLL and JIT-generated
code. */
#endif
#ifdef ALPHA_CONTROL_FP
{
@ -410,40 +418,39 @@ scheme_init_number (Scheme_Env *env)
#endif
#ifdef MZ_LONG_DOUBLE
scheme_long_floating_point_zero = get_long_double_zero();
#if defined(HUGE_VALL) && !defined(USE_DIVIDE_MAKE_INFINITY)
scheme_long_infinity_val = HUGE_VALL;
#else
#ifndef USE_LONG_INFINITY_FUNC
scheme_long_infinity_val = 1.0L / scheme_long_floating_point_zero;
scheme_long_infinity_val = long_double_div(get_long_double_1(), scheme_long_floating_point_zero);
#else
scheme_long_infinity_val = long_infinity();
#endif
#endif
#ifdef ZERO_LONG_MINUS_ZERO_IS_LONG_POS_ZERO
scheme_long_floating_point_nzero = -1.0L / scheme_long_infinity_val;
scheme_long_floating_point_nzero = long_double_div(long_double_neq(long_double_1(), scheme_long_infinity_val));
#else
scheme_long_floating_point_nzero = - scheme_long_floating_point_nzero;
scheme_long_floating_point_nzero = long_double_neg(scheme_long_floating_point_nzero);
#endif
scheme_long_minus_infinity_val = -scheme_long_infinity_val;
long_not_a_number_val = scheme_long_infinity_val + scheme_long_minus_infinity_val;
scheme_long_minus_infinity_val = long_double_neg(scheme_long_infinity_val);
long_not_a_number_val = long_double_plus(scheme_long_infinity_val, scheme_long_minus_infinity_val);
long_not_a_number_val = long_double_sqrt(long_double_neg(get_long_double_1()));
scheme_zerol = scheme_make_long_double(1.0L);
SCHEME_LONG_DBL_VAL(scheme_zerol) = 0.0L;
scheme_nzerol = scheme_make_long_double(-1.0L);
scheme_zerol = scheme_make_long_double(get_long_double_1());
SCHEME_LONG_DBL_VAL(scheme_zerol) = get_long_double_zero();
scheme_nzerol = scheme_make_long_double(long_double_neg(get_long_double_1()));
SCHEME_LONG_DBL_VAL(scheme_nzerol) = scheme_long_floating_point_nzero;
scheme_long_pi = scheme_make_long_double(atan2l(0.0L, -1.0L));
scheme_long_half_pi = scheme_make_long_double(atan2l(0.0L, -1.0L)/2);
scheme_long_pi = scheme_make_long_double(get_long_double_pi());
scheme_long_half_pi = scheme_make_long_double(get_long_double_half_pi());
scheme_long_plus_i = scheme_make_complex(scheme_make_integer(0), scheme_make_integer(1));
scheme_long_minus_i = scheme_make_complex(scheme_make_integer(0), scheme_make_integer(-1));
scheme_long_inf_object = scheme_make_long_double(scheme_long_infinity_val);
scheme_long_minus_inf_object = scheme_make_long_double(scheme_long_minus_infinity_val);
#ifdef NAN_EQUALS_ANYTHING
scheme_long_nan_object = scheme_make_long_double(1L);
scheme_long_nan_object = scheme_make_long_double(get_long_double_1());
SCHEME_LONG_DBL_VAL(scheme_long_nan_object) = long_not_a_number_val;
#else
scheme_long_nan_object = scheme_make_long_double(long_not_a_number_val);
@ -1055,7 +1062,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extflvector-length", p, env);
p = scheme_make_immed_prim(scheme_checked_extflvector_ref, "extflvector-ref", 2, 2);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1064,7 +1071,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extflvector-ref", p, env);
p = scheme_make_immed_prim(scheme_checked_extflvector_set, "extflvector-set!", 3, 3);
if (MZ_LONG_DOUBLE_AND(1))
if (MZ_LONG_DOUBLE_AVAIL_AND(1))
flags = SCHEME_PRIM_IS_NARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1073,7 +1080,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extflvector-set!", p, env);
p = scheme_make_folding_prim(integer_to_extfl, "->extfl", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1082,7 +1089,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("->extfl", p, env);
p = scheme_make_folding_prim(extfl_to_integer, "extfl->exact-integer", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1090,7 +1097,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extfl->exact-integer", p, env);
p = scheme_make_folding_prim(real_to_long_double_flonum, "real->extfl", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1099,7 +1106,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("real->extfl", p, env);
p = scheme_make_folding_prim(extfl_to_exact, "extfl->exact", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(1))
if (MZ_LONG_DOUBLE_AVAIL_AND(1))
flags = SCHEME_PRIM_IS_NARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1107,7 +1114,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extfl->exact", p, env);
p = scheme_make_folding_prim(extfl_to_inexact, "extfl->inexact", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(1))
if (MZ_LONG_DOUBLE_AVAIL_AND(1))
flags = SCHEME_PRIM_IS_NARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1115,7 +1122,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extfl->inexact", p, env);
p = scheme_make_folding_prim(fx_to_extfl, "fx->extfl", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1124,7 +1131,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("fx->extfl", p, env);
p = scheme_make_folding_prim(extfl_to_fx, "extfl->fx", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1135,7 +1142,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
p = scheme_make_folding_prim(extfl_truncate, "extfltruncate", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1145,7 +1152,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extfltruncate", p, env);
p = scheme_make_folding_prim(extfl_round, "extflround", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1155,7 +1162,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extflround", p, env);
p = scheme_make_folding_prim(extfl_ceiling, "extflceiling", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1165,7 +1172,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extflceiling", p, env);
p = scheme_make_folding_prim(extfl_floor, "extflfloor", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1175,7 +1182,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extflfloor", p, env);
p = scheme_make_folding_prim(extfl_sin, "extflsin", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1185,7 +1192,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extflsin", p, env);
p = scheme_make_folding_prim(extfl_cos, "extflcos", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1195,7 +1202,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extflcos", p, env);
p = scheme_make_folding_prim(extfl_tan, "extfltan", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1205,7 +1212,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extfltan", p, env);
p = scheme_make_folding_prim(extfl_asin, "extflasin", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1215,7 +1222,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extflasin", p, env);
p = scheme_make_folding_prim(extfl_acos, "extflacos", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1225,7 +1232,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extflacos", p, env);
p = scheme_make_folding_prim(extfl_atan, "extflatan", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1235,7 +1242,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extflatan", p, env);
p = scheme_make_folding_prim(extfl_log, "extfllog", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1245,7 +1252,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extfllog", p, env);
p = scheme_make_folding_prim(extfl_exp, "extflexp", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1255,7 +1262,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
scheme_add_global_constant("extflexp", p, env);
p = scheme_make_folding_prim(extfl_expt, "extflexpt", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1438,7 +1445,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env)
int flags;
p = scheme_make_folding_prim(unsafe_fx_to_extfl, "unsafe-fx->extfl", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1448,7 +1455,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env)
scheme_add_global_constant("unsafe-fx->extfl", p, env);
p = scheme_make_folding_prim(unsafe_extfl_to_fx, "unsafe-extfl->fx", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(1))
if (MZ_LONG_DOUBLE_AVAIL_AND(1))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1460,7 +1467,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env)
p = scheme_make_immed_prim(unsafe_extflvector_length, "unsafe-extflvector-length",
1, 1);
if (MZ_LONG_DOUBLE_AND(1))
if (MZ_LONG_DOUBLE_AVAIL_AND(1))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1471,7 +1478,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env)
p = scheme_make_immed_prim(unsafe_extflvector_ref, "unsafe-extflvector-ref",
2, 2);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1483,7 +1490,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env)
p = scheme_make_immed_prim(unsafe_extflvector_set, "unsafe-extflvector-set!",
3, 3);
if (MZ_LONG_DOUBLE_AND(1))
if (MZ_LONG_DOUBLE_AVAIL_AND(1))
flags = SCHEME_PRIM_IS_NARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1493,7 +1500,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env)
p = scheme_make_immed_prim(extfl_ref, "unsafe-f80vector-ref",
2, 2);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1505,7 +1512,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env)
p = scheme_make_immed_prim(extfl_set, "unsafe-f80vector-set!",
3, 3);
if (MZ_LONG_DOUBLE_AND(1))
if (MZ_LONG_DOUBLE_AVAIL_AND(1))
flags = SCHEME_PRIM_IS_NARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -1767,41 +1774,41 @@ Scheme_Object *scheme_make_double(double d)
}
#ifdef MZ_LONG_DOUBLE
XFORM_NONGCING static MZ_INLINE int long_minus_zero_p(long double d)
XFORM_NONGCING static MZ_INLINE int long_minus_zero_p(long_double d)
{
return (1 / d) < 0;
return long_double_less(long_double_div(get_long_double_1(), d), get_long_double_zero());
}
int scheme_long_minus_zero_p(long double d)
int scheme_long_minus_zero_p(long_double d)
{
return long_minus_zero_p(d);
}
long double scheme_real_to_long_double(Scheme_Object *r)
long_double scheme_real_to_long_double(Scheme_Object *r)
{
if (SCHEME_INTP(r))
return (long double)SCHEME_INT_VAL(r);
return long_double_from_int(SCHEME_INT_VAL(r));
else if (SCHEME_DBLP(r))
return (long double)SCHEME_DBL_VAL(r);
return long_double_from_double(SCHEME_DBL_VAL(r));
else if (SCHEME_LONG_DBLP(r))
return SCHEME_LONG_DBL_VAL(r);
#ifdef MZ_USE_SINGLE_FLOATS
else if (SCHEME_FLTP(r))
return (long double)SCHEME_FLT_VAL(r);
return long_double_from_float(SCHEME_FLT_VAL(r));
#endif
else if (SCHEME_BIGNUMP(r))
return scheme_bignum_to_long_double(r);
else if (SCHEME_RATIONALP(r))
return scheme_rational_to_long_double(r);
else
return 0.0L;
return get_long_double_zero();
}
Scheme_Object *scheme_make_long_double(long double d)
Scheme_Object *scheme_make_long_double(long_double d)
{
GC_CAN_IGNORE Scheme_Long_Double *sd;
if (d == 0.0L) {
if (long_double_eqv(d, get_long_double_zero())) {
if (long_minus_zero_p(d))
return scheme_nzerol;
#ifdef NAN_EQUALS_ANYTHING
@ -1985,7 +1992,7 @@ static Scheme_Object *
extflonum_available_p(int argc, Scheme_Object *argv[])
{
#ifdef MZ_LONG_DOUBLE
return scheme_true;
return (long_double_available() ? scheme_true : scheme_false);
#else
return scheme_false;
#endif
@ -2032,12 +2039,9 @@ real_to_double_flonum (int argc, Scheme_Object *argv[])
static Scheme_Object *
real_to_long_double_flonum (int argc, Scheme_Object *argv[])
{
CHECK_MZ_LONG_DOUBLE_UNSUPPORTED("real->extfl");
#ifdef MZ_LONG_DOUBLE
return scheme_TO_LONG_DOUBLE(argv[0]);
#else
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
"real->extfl: " NOT_SUPPORTED_STR);
return NULL;
#endif
}
@ -2510,42 +2514,42 @@ double scheme_double_floor(double x) { return floor(x); }
double scheme_double_ceiling(double x) { return ceil(x); }
#ifdef MZ_LONG_DOUBLE
XFORM_NONGCING static long double SCH_ROUNDL(long double d)
XFORM_NONGCING static long_double SCH_ROUNDL(long_double d)
{
long double i, frac;
long_double i, frac;
int invert;
#ifdef FMOD_CAN_RETURN_POS_ZERO
if ((d == 0.0L) && long_minus_zero_p(d))
if (long_double_eqv(d, get_long_double_zero()) && long_minus_zero_p(d))
return d;
#endif
if (d < 0.0L) {
d = -d;
if (long_double_less(d, get_long_double_zero())) {
d = long_double_neg(d);
invert = 1;
} else
invert = 0;
frac = modfl(d, &i);
if (frac < 0.5L)
frac = long_double_modf(d, &i);
if (long_double_less(frac, get_long_double_one_half()))
d = i;
else if (frac > 0.5L)
d = i + 1;
else if (fmodl(i, 2.0L) != 0.0L)
d = i + 1;
else if (long_double_greater(frac, get_long_double_one_half()))
d = long_double_plus(i, get_long_double_1());
else if (!long_double_eqv(long_double_fmod(i, get_long_double_2()), get_long_double_zero()))
d = long_double_plus(i, get_long_double_1());
else
d = i;
if (invert)
d = -d;
d = long_double_neg(d);
return d;
}
long double scheme_long_double_truncate(long double x) { return truncl(x); }
long double scheme_long_double_round(long double x) { return SCH_ROUNDL(x); }
long double scheme_long_double_floor(long double x) { return floorl(x); }
long double scheme_long_double_ceiling(long double x) { return ceill(x); }
long_double scheme_long_double_truncate(long_double x) { return long_double_trunc(x); }
long_double scheme_long_double_round(long_double x) { return SCH_ROUNDL(x); }
long_double scheme_long_double_floor(long_double x) { return long_double_floor(x); }
long_double scheme_long_double_ceiling(long_double x) { return long_double_ceil(x); }
#endif
#ifdef MZ_USE_SINGLE_FLOATS
@ -2922,6 +2926,24 @@ static double SCH_ATAN(double v)
return v;
}
static double SCH_ATAN2(double v, double v2)
{
#ifdef ATAN2_DOESNT_WORK_WITH_INFINITIES
if (MZ_IS_INFINITY(v) && MZ_IS_INFINITY(v2)) {
v = MZ_IS_POS_INFINITY(v) ? 1.0 : -1.0;
v2 = MZ_IS_POS_INFINITY(v2) ? 1.0 : -1.0;
}
#endif
#ifdef ATAN2_DOESNT_WORK_WITH_NAN
if (MZ_IS_NAN(v) || MZ_IS_NAN(v2))
return scheme_nan_object;
#endif
return atan2(v, v2);
}
#ifdef LOG_ZERO_ISNT_NEG_INF
static double SCH_LOG(double d) { if (d == 0.0) return scheme_minus_infinity_val; else return log(d); }
#else
@ -2939,14 +2961,14 @@ double scheme_double_log(double x) { return SCH_LOG(x); }
double scheme_double_exp(double x) { return exp(x); }
#ifdef MZ_LONG_DOUBLE
long double scheme_long_double_sin(long double x) { return sinl(x); }
long double scheme_long_double_cos(long double x) { return cosl(x); }
long double scheme_long_double_tan(long double x) { return tanl(x); }
long double scheme_long_double_asin(long double x) { return asinl(x); }
long double scheme_long_double_acos(long double x) { return acosl(x); }
long double scheme_long_double_atan(long double x) { return atanl(x); }
long double scheme_long_double_log(long double x) { return logl(x); }
long double scheme_long_double_exp(long double x) { return exp(x); }
long_double scheme_long_double_sin(long_double x) { return long_double_sin(x); }
long_double scheme_long_double_cos(long_double x) { return long_double_cos(x); }
long_double scheme_long_double_tan(long_double x) { return long_double_tan(x); }
long_double scheme_long_double_asin(long_double x) { return long_double_asin(x); }
long_double scheme_long_double_acos(long_double x) { return long_double_acos(x); }
long_double scheme_long_double_atan(long_double x) { return long_double_atan(x); }
long_double scheme_long_double_log(long_double x) { return long_double_log(x); }
long_double scheme_long_double_exp(long_double x) { return long_double_exp(x); }
#endif
@ -3078,19 +3100,7 @@ atan_prim (int argc, Scheme_Object *argv[])
}
}
#ifdef ATAN2_DOESNT_WORK_WITH_INFINITIES
if (MZ_IS_INFINITY(v) && MZ_IS_INFINITY(v2)) {
v = MZ_IS_POS_INFINITY(v) ? 1.0 : -1.0;
v2 = MZ_IS_POS_INFINITY(v2) ? 1.0 : -1.0;
}
#endif
#ifdef ATAN2_DOESNT_WORK_WITH_NAN
if (MZ_IS_NAN(v) || MZ_IS_NAN(v2))
return scheme_nan_object;
#endif
v = atan2(v, v2);
v = SCH_ATAN2(v, v2);
} else { /* 1-argument case */
if (argv[0] == zeroi)
return zeroi;
@ -3258,7 +3268,7 @@ static double protected_pow(double x, double y)
word while calling pow(); note that the x87 control
word is thread-specific */
#ifndef MZ_LONG_DOUBLE
to_extended_prec();
to_extended_prec();
#endif
x = pow(x, y);
#ifndef MZ_LONG_DOUBLE
@ -3268,10 +3278,10 @@ static double protected_pow(double x, double y)
}
#ifdef MZ_LONG_DOUBLE
static long double protected_powl(long double x, long double y)
static long_double protected_powl(long_double x, long_double y)
{
/* we use extended precision at all */
x = powl(x, y);
x = long_double_pow(x, y);
return x;
}
#endif
@ -3279,7 +3289,7 @@ static long double protected_powl(long double x, long double y)
#else
# define protected_pow pow
# ifdef MZ_LONG_DOUBLE
# define protected_powl powl
# define protected_powl long_double_pow
# endif
#endif
@ -3373,25 +3383,25 @@ static double sch_pow(double x, double y)
}
#ifdef MZ_LONG_DOUBLE
static long double sch_powl(long double x, long double y)
static long_double sch_powl(long_double x, long_double y)
{
/* Like sch_pow(), but with an extra case for x < 0 and non-integer y */
if (x == 1.0L)
return 1.0L; /* even for NaN */
else if (y == 0.0L)
return 1.0L; /* even for NaN */
if (long_double_eqv(x, get_long_double_1()))
return get_long_double_1(); /* even for NaN */
else if (long_double_is_zero(y))
return get_long_double_1(); /* even for NaN */
else if (MZ_IS_LONG_NAN(x))
return long_not_a_number_val;
else if (MZ_IS_LONG_NAN(y))
return long_not_a_number_val;
else if (x == 0.0L) {
else if (long_double_eqv(x, get_long_double_zero())) {
int neg = 0;
if (y < 0L) {
if (long_double_less(y, get_long_double_zero())) {
neg = 1;
y = -y;
y = long_double_neg(y);
}
if (fmodl(y, 2.0L) == 1.0L) {
if (long_double_eqv(long_double_fmod(y, get_long_double_2()), get_long_double_1())) {
if (neg) {
if (long_minus_zero_p(x))
return scheme_long_minus_infinity_val;
@ -3403,45 +3413,45 @@ static long double sch_powl(long double x, long double y)
if (neg)
return scheme_long_infinity_val;
else
return 0.0L;
return get_long_double_zero();
}
} else if (MZ_IS_LONG_POS_INFINITY(y)) {
if (x == -1.0L)
return 1.0L;
else if ((x < 1.0L) && (x > -1.0L))
return 0.0L;
if (long_double_eqv(x, get_long_double_minus_1()))
return get_long_double_1();
else if ((long_double_less(x, get_long_double_1())) && (long_double_greater(x, get_long_double_minus_1())))
return get_long_double_zero();
else
return scheme_long_infinity_val;
} else if (MZ_IS_LONG_NEG_INFINITY(y)) {
if (x == -1.0L)
return 1.0L;
else if ((x < 1.0L) && (x > -1.0L))
if (long_double_eqv(x, get_long_double_minus_1()))
return get_long_double_1();
else if (long_double_less(x, get_long_double_1()) && (long_double_greater(x, get_long_double_minus_1())))
return scheme_long_infinity_val;
else
return 0.0L;
return get_long_double_zero();
} else if (MZ_IS_LONG_POS_INFINITY(x)) {
if (y < 0.0L)
return 0.0L;
if (long_double_less(y, get_long_double_zero()))
return get_long_double_zero();
else
return scheme_long_infinity_val;
} else if (MZ_IS_LONG_NEG_INFINITY(x)) {
int neg = 0;
if (y < 0.0L) {
if (long_double_less(y, get_long_double_zero())) {
neg = 1;
y = -y;
y = long_double_neg(y);
}
if (fmodl(y, 2.0L) == 1.0L) {
if (long_double_eqv(long_double_fmod(y, get_long_double_2()), get_long_double_1())) {
if (neg)
return scheme_long_floating_point_nzero;
else
return scheme_long_minus_infinity_val;
} else {
if (neg)
return 0.0L;
return get_long_double_zero();
else
return scheme_long_infinity_val;
}
} else if ((x < 0.0L) && (y != floorl(y))) {
} else if (long_double_less(x, get_long_double_zero()) && (!long_double_eqv(y, long_double_floor(y)))) {
/* powl() on some platforms has trouble with this case */
return long_not_a_number_val;
} else {
@ -3613,7 +3623,7 @@ double scheme_double_expt(double x, double y) {
}
#ifdef MZ_LONG_DOUBLE
long double scheme_long_double_expt(long double x, long double y) {
long_double scheme_long_double_expt(long_double x, long_double y) {
return sch_powl(x, y);
}
#endif
@ -3801,7 +3811,7 @@ static Scheme_Object *angle(int argc, Scheme_Object *argv[])
id = TO_DOUBLE_VAL(i);
rd = TO_DOUBLE_VAL(r);
v = atan2(id, rd);
v = SCH_ATAN2(id, rd);
#ifdef MZ_USE_SINGLE_FLOATS
if (was_single)
@ -3960,13 +3970,13 @@ static Scheme_Object *exact_to_extfl (int argc, Scheme_Object *argv[])
Scheme_Type t;
if (SCHEME_INTP(o))
return scheme_make_long_double(SCHEME_INT_VAL(o));
return scheme_make_long_double(long_double_from_int(SCHEME_INT_VAL(o)));
t = _SCHEME_TYPE(o);
if (t == scheme_float_type)
return scheme_make_long_double(SCHEME_FLOAT_VAL(o));
return scheme_make_long_double(long_double_from_double(SCHEME_FLOAT_VAL(o)));
if (t == scheme_double_type)
return scheme_make_long_double(SCHEME_DBL_VAL(o));
return scheme_make_long_double(long_double_from_double(SCHEME_DBL_VAL(o)));
if (t == scheme_long_double_type)
return o;
if (t == scheme_bignum_type)
@ -3985,7 +3995,9 @@ extfl_to_exact (int argc, Scheme_Object *argv[])
{
#ifdef MZ_LONG_DOUBLE
Scheme_Object *o = argv[0], *i;
long double d;
long_double d;
CHECK_MZ_LONG_DOUBLE_UNSUPPORTED("extfl->exact");
if (!SCHEME_LONG_DBLP(o))
scheme_wrong_type("extfl->exact", "extflonum", 0, argc, argv);
@ -3993,8 +4005,8 @@ extfl_to_exact (int argc, Scheme_Object *argv[])
d = SCHEME_LONG_DBL_VAL(o);
/* Try simple case: */
i = scheme_make_integer((intptr_t)d);
if ((long double)SCHEME_INT_VAL(i) == d) {
i = scheme_make_integer((intptr_t)int_from_long_double(d));
if (long_double_eqv_i(int_from_long_double(d), d)) {
# ifdef NAN_EQUALS_ANYTHING
if (!MZ_IS_LONG_NAN(d))
#endif
@ -4003,9 +4015,7 @@ extfl_to_exact (int argc, Scheme_Object *argv[])
return scheme_rational_from_long_double(d);
#else
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
"extfl->exact: " NOT_SUPPORTED_STR);
return NULL;
CHECK_MZ_LONG_DOUBLE_UNSUPPORTED("extfl->exact");
#endif
}
@ -4015,10 +4025,12 @@ extfl_to_inexact (int argc, Scheme_Object *argv[])
#ifdef MZ_LONG_DOUBLE
Scheme_Object *o = argv[0];
CHECK_MZ_LONG_DOUBLE_UNSUPPORTED("extfl->inexact");
if (!SCHEME_LONG_DBLP(o))
scheme_wrong_type("extfl->inexact", "extflonum", 0, argc, argv);
return scheme_make_double(SCHEME_LONG_DBL_VAL(o));
return scheme_make_double(double_from_long_double(SCHEME_LONG_DBL_VAL(o)));
#else
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
"extfl->inexact: " NOT_SUPPORTED_STR);
@ -4523,6 +4535,9 @@ Scheme_Object *scheme_checked_flvector_set (int argc, Scheme_Object *argv[])
#ifndef MZ_LONG_DOUBLE
# define Scheme_Long_Double_Vector void
#endif
#if !defined(MZ_LONG_DOUBLE) || defined(MZ_LONG_DOUBLE_API_IS_EXTERNAL)
static Scheme_Object *unsupported(const char *name)
{
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
@ -4539,7 +4554,7 @@ Scheme_Long_Double_Vector *scheme_alloc_extflvector(intptr_t size)
vec = (Scheme_Long_Double_Vector *)scheme_malloc_fail_ok(scheme_malloc_atomic_tagged,
sizeof(Scheme_Long_Double_Vector)
+ ((size - mzFLEX_DELTA) * sizeof(long double)));
+ ((size - mzFLEX_DELTA) * sizeof(long_double)));
vec->iso.so.type = scheme_extflvector_type;
vec->size = size;
@ -4575,6 +4590,8 @@ static Scheme_Object *do_extflvector (const char *name, Scheme_Long_Double_Vecto
#ifdef MZ_LONG_DOUBLE
int i;
WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported(name));
for (i = 0; i < argc; i++) {
if (!SCHEME_LONG_DBLP(argv[i])) {
scheme_wrong_contract(name, "extflonum?", i, argc, argv);
@ -4612,9 +4629,11 @@ static Scheme_Object *do_make_extflvector (const char *name, int as_shared, int
#ifdef MZ_LONG_DOUBLE
Scheme_Long_Double_Vector *vec;
intptr_t size;
long double d;
long_double d;
int i;
WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported(name));
if (SCHEME_INTP(argv[0]))
size = SCHEME_INT_VAL(argv[0]);
else if (SCHEME_BIGNUMP(argv[0])) {
@ -4642,7 +4661,7 @@ static Scheme_Object *do_make_extflvector (const char *name, int as_shared, int
if (argc > 1)
d = SCHEME_LONG_DBL_VAL(argv[1]);
else
d = 0.0L;
d = get_long_double_zero();
for (i = 0; i < size; i++) {
vec->els[i] = d;
}
@ -4666,6 +4685,8 @@ static Scheme_Object *make_shared_extflvector (int argc, Scheme_Object *argv[])
Scheme_Object *scheme_extflvector_length(Scheme_Object *vec)
{
#ifdef MZ_LONG_DOUBLE
WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("extflvector-length"));
if (!SCHEME_EXTFLVECTORP(vec))
scheme_wrong_contract("extflvector-length", "extflvector?", 0, 1, &vec);
@ -4678,10 +4699,14 @@ Scheme_Object *scheme_extflvector_length(Scheme_Object *vec)
static Scheme_Object *extfl_ref (int argc, Scheme_Object *argv[])
{
#ifdef MZ_LONG_DOUBLE
long double v;
long_double v;
Scheme_Object *p;
WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("unsafe-f80vector-ref"));
p = ((Scheme_Structure *)argv[0])->slots[0];
v = ((long double *)SCHEME_CPTR_VAL(p))[SCHEME_INT_VAL(argv[1])];
v = long_double_array_ref(SCHEME_CPTR_VAL(p), SCHEME_INT_VAL(argv[1]));
return scheme_make_long_double(v);
#else
return unsupported("unsafe-f80vector-ref");
@ -4693,7 +4718,8 @@ static Scheme_Object *extfl_set (int argc, Scheme_Object *argv[])
#ifdef MZ_LONG_DOUBLE
Scheme_Object *p;
p = ((Scheme_Structure *)argv[0])->slots[0];
((long double *)SCHEME_CPTR_VAL(p))[SCHEME_INT_VAL(argv[1])] = SCHEME_LONG_DBL_VAL(argv[2]);
long_double_array_set(SCHEME_CPTR_VAL(p), SCHEME_INT_VAL(argv[1]), SCHEME_LONG_DBL_VAL(argv[2]));
return scheme_void;
#else
return unsupported("unsafe-f80vector-set!");
@ -4708,10 +4734,12 @@ static Scheme_Object *extflvector_length (int argc, Scheme_Object *argv[])
Scheme_Object *scheme_checked_extflvector_ref (int argc, Scheme_Object *argv[])
{
#ifdef MZ_LONG_DOUBLE
long double d;
long_double d;
Scheme_Object *vec;
intptr_t len, pos;
WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("extflvector-ref"));
vec = argv[0];
if (!SCHEME_EXTFLVECTORP(vec))
scheme_wrong_contract("extflvector-ref", "extflvector?", 0, argc, argv);
@ -4740,6 +4768,8 @@ Scheme_Object *scheme_checked_extflvector_set (int argc, Scheme_Object *argv[])
Scheme_Object *vec;
intptr_t len, pos;
WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("extflvector-set!"));
vec = argv[0];
if (!SCHEME_EXTFLVECTORP(vec))
scheme_wrong_contract("extflvector-set!", "extflvector?", 0, argc, argv);
@ -5061,9 +5091,10 @@ static Scheme_Object *fx_to_extfl (int argc, Scheme_Object *argv[])
{
#ifdef MZ_LONG_DOUBLE
intptr_t v;
WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("fx->extfl"));
if (!SCHEME_INTP(argv[0])) scheme_wrong_contract("fx->extfl", "fixnum?", 0, argc, argv);
v = SCHEME_INT_VAL(argv[0]);
return scheme_make_long_double(v);
return scheme_make_long_double(long_double_from_int(v));
#else
return unsupported("fx->extfl");
#endif
@ -5072,17 +5103,18 @@ static Scheme_Object *fx_to_extfl (int argc, Scheme_Object *argv[])
static Scheme_Object *extfl_to_fx (int argc, Scheme_Object *argv[])
{
#ifdef MZ_LONG_DOUBLE
long double d;
long_double d;
intptr_t v;
Scheme_Object *o;
if (!SCHEME_LONG_DBLP(argv[0])
/* && !scheme_is_integer(argv[0]) */)
WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("extfl->fx"));
if (!SCHEME_LONG_DBLP(argv[0]))
scheme_wrong_contract("extfl->fx", "(and/c extflonum?)", 0, argc, argv);
d = SCHEME_LONG_DBL_VAL(argv[0]);
v = (intptr_t)d;
if ((long double)v == d) {
v = (intptr_t)int_from_long_double(d);
if (long_double_eqv_i(v, d)) {
o = scheme_make_integer_value(v);
if (SCHEME_INTP(o))
return o;
@ -5101,7 +5133,8 @@ static Scheme_Object *extfl_to_fx (int argc, Scheme_Object *argv[])
# define SAFE_EXTFL(op) \
static Scheme_Object * extfl_ ## op (int argc, Scheme_Object *argv[]) \
{ \
long double v; \
long_double v; \
WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("extfl" #op)); \
if (!SCHEME_LONG_DBLP(argv[0])) scheme_wrong_contract("extfl" #op, "extflonum?", 0, argc, argv); \
v = scheme_long_double_ ## op (SCHEME_LONG_DBL_VAL(argv[0])); \
return scheme_make_long_double(v); \
@ -5131,7 +5164,7 @@ SAFE_EXTFL(log)
# define SAFE_BIN_EXTFL(op) \
static Scheme_Object * extfl_ ## op (int argc, Scheme_Object *argv[]) \
{ \
long double v; \
long_double v; \
if (!SCHEME_LONG_DBLP(argv[0])) scheme_wrong_contract("extfl" #op, "extflonum?", 0, argc, argv); \
if (!SCHEME_LONG_DBLP(argv[1])) scheme_wrong_contract("extfl" #op, "extflonum?", 1, argc, argv); \
v = scheme_long_double_ ## op (SCHEME_LONG_DBL_VAL(argv[0]), SCHEME_LONG_DBL_VAL(argv[1])); \
@ -5234,7 +5267,7 @@ static Scheme_Object *unsafe_fx_to_extfl (int argc, Scheme_Object *argv[])
intptr_t v;
if (scheme_current_thread->constant_folding) return exact_to_extfl(argc, argv);
v = SCHEME_INT_VAL(argv[0]);
return scheme_make_long_double(v);
return scheme_make_long_double(long_double_from_int(v));
#else
return fx_to_extfl(argc, argv);
#endif
@ -5245,7 +5278,7 @@ static Scheme_Object *unsafe_extfl_to_fx (int argc, Scheme_Object *argv[])
#ifdef MZ_LONG_DOUBLE
intptr_t v;
if (scheme_current_thread->constant_folding) return extfl_to_exact(argc, argv);
v = (intptr_t)(SCHEME_LONG_DBL_VAL(argv[0]));
v = (intptr_t)int_from_long_double(SCHEME_LONG_DBL_VAL(argv[0]));
return scheme_make_integer(v);
#else
return extfl_to_fx(argc, argv);
@ -5265,7 +5298,7 @@ static Scheme_Object *unsafe_extflvector_ref (int argc, Scheme_Object *argv[])
{
#ifdef MZ_LONG_DOUBLE
intptr_t pos;
long double d;
long_double d;
pos = SCHEME_INT_VAL(argv[1]);
d = SCHEME_EXTFLVEC_ELS(argv[0])[pos];
@ -5389,6 +5422,7 @@ static Scheme_Object *unsafe_flimag_part (int argc, Scheme_Object *argv[])
static Scheme_Object *integer_to_extfl (int argc, Scheme_Object *argv[])
{
#ifdef MZ_LONG_DOUBLE
WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("->extfl"));
if (SCHEME_INTP(argv[0])
|| SCHEME_BIGNUMP(argv[0])) {
return exact_to_extfl(argc, argv);
@ -5404,6 +5438,7 @@ static Scheme_Object *integer_to_extfl (int argc, Scheme_Object *argv[])
static Scheme_Object *extfl_to_integer (int argc, Scheme_Object *argv[])
{
#ifdef MZ_LONG_DOUBLE
WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("extfl->exact-integer"));
if (SCHEME_LONG_DBLP(argv[0])) {
Scheme_Object *o;
o = extfl_to_exact(argc, argv);
@ -5417,3 +5452,7 @@ static Scheme_Object *extfl_to_integer (int argc, Scheme_Object *argv[])
return unsupported("extfl->exact-integer");
#endif
}
#ifdef MZ_LONG_DOUBLE_API_IS_EXTERNAL
# include "longdouble/longdouble.c"
#endif

66
src/racket/src/numcomp.c
View File

@ -256,7 +256,7 @@ void scheme_init_extfl_numcomp(Scheme_Env *env)
int flags;
p = scheme_make_folding_prim(extfl_eq, "extfl=", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -265,7 +265,7 @@ void scheme_init_extfl_numcomp(Scheme_Env *env)
scheme_add_global_constant("extfl=", p, env);
p = scheme_make_folding_prim(extfl_lt, "extfl<", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -274,7 +274,7 @@ void scheme_init_extfl_numcomp(Scheme_Env *env)
scheme_add_global_constant("extfl<", p, env);
p = scheme_make_folding_prim(extfl_gt, "extfl>", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -283,7 +283,7 @@ void scheme_init_extfl_numcomp(Scheme_Env *env)
scheme_add_global_constant("extfl>", p, env);
p = scheme_make_folding_prim(extfl_lt_eq, "extfl<=", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -292,7 +292,7 @@ void scheme_init_extfl_numcomp(Scheme_Env *env)
scheme_add_global_constant("extfl<=", p, env);
p = scheme_make_folding_prim(extfl_gt_eq, "extfl>=", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -301,7 +301,7 @@ void scheme_init_extfl_numcomp(Scheme_Env *env)
scheme_add_global_constant("extfl>=", p, env);
p = scheme_make_folding_prim(extfl_min, "extflmin", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -311,7 +311,7 @@ void scheme_init_extfl_numcomp(Scheme_Env *env)
scheme_add_global_constant("extflmin", p, env);
p = scheme_make_folding_prim(extfl_max, "extflmax", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -442,7 +442,7 @@ void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env)
int flags;
p = scheme_make_folding_prim(unsafe_extfl_eq, "unsafe-extfl=", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -452,7 +452,7 @@ void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env)
scheme_add_global_constant("unsafe-extfl=", p, env);
p = scheme_make_folding_prim(unsafe_extfl_lt, "unsafe-extfl<", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -462,7 +462,7 @@ void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env)
scheme_add_global_constant("unsafe-extfl<", p, env);
p = scheme_make_folding_prim(unsafe_extfl_gt, "unsafe-extfl>", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -472,7 +472,7 @@ void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env)
scheme_add_global_constant("unsafe-extfl>", p, env);
p = scheme_make_folding_prim(unsafe_extfl_lt_eq, "unsafe-extfl<=", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -482,7 +482,7 @@ void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env)
scheme_add_global_constant("unsafe-extfl<=", p, env);
p = scheme_make_folding_prim(unsafe_extfl_gt_eq, "unsafe-extfl>=", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -492,7 +492,7 @@ void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env)
scheme_add_global_constant("unsafe-extfl>=", p, env);
p = scheme_make_folding_prim(unsafe_extfl_min, "unsafe-extflmin", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -503,7 +503,7 @@ void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env)
scheme_add_global_constant("unsafe-extflmin", p, env);
p = scheme_make_folding_prim(unsafe_extfl_max, "unsafe-extflmax", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
@ -826,10 +826,11 @@ UNSAFE_FL_BINOP(unsafe_fl_max, >, bin_max, argv[0], argv[1], CHECK_ARGV0_NAN)
# define SAFE_EXTFL_X(name, sname, op, T, F, PRE_CHECK) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
CHECK_MZ_LONG_DOUBLE_UNSUPPORTED(sname); \
if (!SCHEME_LONG_DBLP(argv[0])) scheme_wrong_contract(sname, "extflonum?", 0, argc, argv); \
if (!SCHEME_LONG_DBLP(argv[1])) scheme_wrong_contract(sname, "extflonum?", 1, argc, argv); \
PRE_CHECK \
if (SCHEME_LONG_DBL_VAL(argv[0]) op SCHEME_LONG_DBL_VAL(argv[1])) \
if (op(SCHEME_LONG_DBL_VAL(argv[0]), SCHEME_LONG_DBL_VAL(argv[1]))) \
return T; \
else \
return F; \
@ -846,16 +847,16 @@ UNSAFE_FL_BINOP(unsafe_fl_max, >, bin_max, argv[0], argv[1], CHECK_ARGV0_NAN)
#define SAFE_EXTFL(name, sname, op) SAFE_EXTFL_X(name, sname, op, scheme_true, scheme_false, ;)
SAFE_EXTFL(extfl_eq, "extfl=", ==)
SAFE_EXTFL(extfl_lt, "extfl<", <)
SAFE_EXTFL(extfl_gt, "extfl>", >)
SAFE_EXTFL(extfl_lt_eq, "extfl<=", <=)
SAFE_EXTFL(extfl_gt_eq, "extfl>=", >=)
SAFE_EXTFL(extfl_eq, "extfl=", long_double_eqv)
SAFE_EXTFL(extfl_lt, "extfl<", long_double_less)
SAFE_EXTFL(extfl_gt, "extfl>", long_double_greater)
SAFE_EXTFL(extfl_lt_eq, "extfl<=", long_double_less_or_eqv)
SAFE_EXTFL(extfl_gt_eq, "extfl>=", long_double_greater_or_eqv)
#define CHECK_ARGV0_LONG_NAN { if (MZ_IS_LONG_NAN(SCHEME_LONG_DBL_VAL(argv[0]))) return argv[0]; }
SAFE_EXTFL_X(extfl_min, "extflmin", <, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
SAFE_EXTFL_X(extfl_max, "extflmax", >, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
SAFE_EXTFL_X(extfl_min, "extflmin", long_double_less, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
SAFE_EXTFL_X(extfl_max, "extflmax", long_double_greater, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
#ifdef MZ_LONG_DOUBLE
/* Unsafe EXTFL comparisons. Return boolean */
@ -863,7 +864,7 @@ SAFE_EXTFL_X(extfl_max, "extflmax", >, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
# define UNSAFE_EXTFL_COMP(name, op) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
if (SCHEME_LONG_DBL_VAL(argv[0]) op SCHEME_LONG_DBL_VAL(argv[1])) \
if (op(SCHEME_LONG_DBL_VAL(argv[0]), SCHEME_LONG_DBL_VAL(argv[1]))) \
return scheme_true; \
else \
return scheme_false; \
@ -875,7 +876,8 @@ SAFE_EXTFL_X(extfl_max, "extflmax", >, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
PRE_CHECK \
if (SCHEME_LONG_DBL_VAL(argv[0]) op SCHEME_LONG_DBL_VAL(argv[1])) \
CHECK_MZ_LONG_DOUBLE_UNSUPPORTED("extfl" #op); \
if (op(SCHEME_LONG_DBL_VAL(argv[0]), SCHEME_LONG_DBL_VAL(argv[1]))) \
return T; \
else \
return F; \
@ -885,18 +887,18 @@ SAFE_EXTFL_X(extfl_max, "extflmax", >, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, \
"extfl" #op ": " NOT_SUPPORTED_STR); \
"unsafe-extfl" #op ": " NOT_SUPPORTED_STR); \
return NULL; \
}
# define UNSAFE_EXTFL_BINOP(name, op, T, F, PRE_CHECK) UNSAFE_EXTFL_COMP(name, op)
#endif
UNSAFE_EXTFL_COMP(unsafe_extfl_eq, ==)
UNSAFE_EXTFL_COMP(unsafe_extfl_lt, <)
UNSAFE_EXTFL_COMP(unsafe_extfl_gt, >)
UNSAFE_EXTFL_COMP(unsafe_extfl_lt_eq, <=)
UNSAFE_EXTFL_COMP(unsafe_extfl_gt_eq, >=)
UNSAFE_EXTFL_COMP(unsafe_extfl_eq, long_double_eqv)
UNSAFE_EXTFL_COMP(unsafe_extfl_lt, long_double_less)
UNSAFE_EXTFL_COMP(unsafe_extfl_gt, long_double_greater)
UNSAFE_EXTFL_COMP(unsafe_extfl_lt_eq, long_double_less_or_eqv)
UNSAFE_EXTFL_COMP(unsafe_extfl_gt_eq, long_double_greater_or_eqv)
UNSAFE_EXTFL_BINOP(unsafe_extfl_min, <, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
UNSAFE_EXTFL_BINOP(unsafe_extfl_max, >, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
UNSAFE_EXTFL_BINOP(unsafe_extfl_min, long_double_less, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
UNSAFE_EXTFL_BINOP(unsafe_extfl_max, long_double_greater, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)

135
src/racket/src/numstr.c
View File

@ -263,7 +263,7 @@ static Scheme_Object *wrap_as_long_double(const char *s, int radix)
Scheme_Object *make_any_long_double()
{
#ifdef MZ_LONG_DOUBLE
return scheme_make_long_double(0.0L);
return scheme_make_long_double(get_long_double_zero());
#else
return wrap_as_long_double("1t0", 10);
#endif
@ -364,12 +364,6 @@ static Scheme_Object *read_special_number(const mzchar *str, int pos)
return NULL;
}
#ifdef MZ_LONG_DOUBLE
# define WIDEST_DOUBLE long double
#else
# define WIDEST_DOUBLE double
#endif
/* Exponent threshold for obvious infinity. Must be at least
max(MAX_FAST_FLOATREAD_LEN, MAX_FLOATREAD_PRECISION_DIGITS) more
than the larget possible FP exponent. */
@ -389,7 +383,7 @@ static Scheme_Object *read_special_number(const mzchar *str, int pos)
END_XFORM_ARITH;
# endif
static WIDEST_DOUBLE STRTOD(const char *orig_c, char **f, int extfl)
static double STRTOD(const char *orig_c, char **f, int extfl)
{
int neg = 0;
int found_dot = 0, is_infinity = 0, is_zero = 0;
@ -497,11 +491,7 @@ static WIDEST_DOUBLE STRTOD(const char *orig_c, char **f, int extfl)
START_XFORM_ARITH;
# endif
#else
# ifdef MZ_LONG_DOUBLE
# define STRTOD(x, y, extfl) strtold(x, y)
# else
# define STRTOD(x, y, extfl) strtod(x, y)
# endif
# define STRTOD(x, y, extfl) strtod(x, y)
#endif
static Scheme_Object *CHECK_SINGLE(Scheme_Object *v, int s, int long_dbl)
@ -1213,7 +1203,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
&& (has_decimal || has_expt)
&& (len <= MAX_FAST_FLOATREAD_LEN)
&& (!is_long_double || MZ_LONG_DOUBLE_AND(1))) {
WIDEST_DOUBLE d;
double d = 1.0;
long_double ld;
GC_CAN_IGNORE char *ptr;
if (has_expt && !(str[has_expt + 1])) {
@ -1246,7 +1237,12 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
loc = scheme_push_c_numeric_locale();
d = STRTOD(ffl_buf, &ptr, is_long_double);
#ifdef MZ_LONG_DOUBLE
if (is_long_double)
ld = long_double_from_string(ffl_buf, &ptr);
else
#endif
d = STRTOD(ffl_buf, &ptr, 0);
scheme_pop_c_numeric_locale(loc);
@ -1286,20 +1282,27 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
/* Make sure it's -0.0 */
#ifdef MZ_USE_SINGLE_FLOATS
if (sgl) return scheme_nzerof;
#endif
#ifdef MZ_LONG_DOUBLE
if (is_long_double) return scheme_nzerol;
#endif
return scheme_nzerod;
}
}
#ifdef MZ_LONG_DOUBLE
if (is_long_double && long_double_is_zero(ld)) {
if (str[delta] == '-') {
/* Make sure it's -0.0 */
return scheme_nzerol;
}
}
#endif
#ifdef MZ_USE_SINGLE_FLOATS
if (sgl)
return scheme_make_float((float)d);
#endif
#ifdef MZ_LONG_DOUBLE
if (is_long_double) return scheme_make_long_double(d);
if (is_long_double) return scheme_make_long_double(ld);
#endif
return scheme_make_double(d);
}
@ -1488,8 +1491,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
if (is_long_double) {
#ifdef MZ_LONG_DOUBLE
n = scheme_TO_LONG_DOUBLE(n);
if ((str[delta] == '-') && (SCHEME_LONG_DBL_VAL(n) == 0.0))
n = scheme_make_long_double(-SCHEME_LONG_DBL_VAL(n));
if ((str[delta] == '-') && (long_double_is_zero(SCHEME_LONG_DBL_VAL(n))))
n = scheme_make_long_double(long_double_neg(SCHEME_LONG_DBL_VAL(n)));
#else
/* simply preserve the printable format */
n = wrap_as_long_double(scheme_utf8_encode_to_buffer(str, len, NULL, 0), radix);
@ -1727,51 +1730,51 @@ string_to_number (int argc, Scheme_Object *argv[])
return v;
}
char *scheme_X_double_to_string (WIDEST_DOUBLE d, char* s, int slen, int was_single, int extfl, int *used_buffer)
char *scheme_X_double_to_string (double d, char* s, int slen, int was_single, int extfl, int *used_buffer, long_double ld)
{
if (MZ_IS_NAN(d)) {
#ifdef MZ_LONG_DOUBLE
if (extfl && MZ_IS_LONG_NAN(ld)) {
return long_not_a_number_str;
} else if (extfl && MZ_IS_LONG_POS_INFINITY(ld)) {
return long_infinity_str;
} else if (extfl && MZ_IS_LONG_NEG_INFINITY(ld)) {
return long_minus_infinity_str;
} else if (extfl && long_double_is_zero(ld)) {
if (scheme_long_minus_zero_p(ld))
return "-0.0t0";
else
return "0.0t0";
}
#endif
if (!extfl && MZ_IS_NAN(d)) {
#ifdef MZ_USE_SINGLE_FLOATS
if (was_single) return single_not_a_number_str;
#endif
#ifdef MZ_LONG_DOUBLE
if (extfl) return long_not_a_number_str;
#endif
return not_a_number_str;
} else if (MZ_IS_POS_INFINITY(d)) {
} else if (!extfl && MZ_IS_POS_INFINITY(d)) {
#ifdef MZ_USE_SINGLE_FLOATS
if (was_single) return single_infinity_str;
#endif
#ifdef MZ_LONG_DOUBLE
if (extfl) return long_infinity_str;
#endif
return infinity_str;
} else if (MZ_IS_NEG_INFINITY(d)) {
} else if (!extfl && MZ_IS_NEG_INFINITY(d)) {
#ifdef MZ_USE_SINGLE_FLOATS
if (was_single) return single_minus_infinity_str;
#endif
#ifdef MZ_LONG_DOUBLE
if (extfl) return long_minus_infinity_str;
#endif
return minus_infinity_str;
} else if (d == 0.0) {
} else if (!extfl && d == 0.0) {
/* Check for -0.0, since some printers get it wrong. */
if (scheme_long_minus_zero_p(d)) {
if (scheme_minus_zero_p(d)) {
#ifdef MZ_USE_SINGLE_FLOATS
if (was_single) return "-0.0f0";
#endif
#ifdef MZ_USE_SINGLE_FLOATS
if (extfl) return "-0.0t0";
#endif
return "-0.0";
}
}
#ifdef MZ_USE_SINGLE_FLOATS
if (was_single) return "0.0f0";
#endif
#ifdef MZ_USE_SINGLE_FLOATS
if (extfl) return "0.0t0";
#endif
return "0.0";
} else {
}
else {
/* Initial count for significant digits is 14 (double), 6 digits
(single), or 18 (extended). That's big enough to get most
right, small enough to avoid nonsense digits. But we'll loop in
@ -1787,20 +1790,23 @@ char *scheme_X_double_to_string (WIDEST_DOUBLE d, char* s, int slen, int was_sin
digits = 14;
loc = scheme_push_c_numeric_locale();
while (digits < 30 && digits < slen) {
WIDEST_DOUBLE check;
double check;
#ifdef MZ_LONG_DOUBLE
long_double long_check;
#endif
GC_CAN_IGNORE char *ptr;
#ifdef MZ_LONG_DOUBLE
if (extfl)
sprintf(buffer, "%.*Lg", digits, d);
long_double_sprint(buffer, digits, ld);
else
#endif
sprintf(buffer, "%.*g", digits, (double)d);
sprintf(buffer, "%.*g", digits, d);
/* Did we get read-write invariance, yet? */
#ifdef MZ_LONG_DOUBLE
if (extfl)
check = strtold(buffer, &ptr);
long_check = long_double_from_string(buffer, &ptr);
else
#endif
check = strtod(buffer, &ptr);
@ -1812,13 +1818,13 @@ char *scheme_X_double_to_string (WIDEST_DOUBLE d, char* s, int slen, int was_sin
if ((float)check == (float)d)
break;
#endif
#ifdef MZ_USE_SINGLE_FLOATS
#ifdef MZ_LONG_DOUBLE
} else if (extfl) {
if (check == d)
if (long_double_eqv(long_check, ld))
break;
#endif
} else
if ((double)check == (double)d)
if (check == d)
break;
digits++;
@ -1863,15 +1869,18 @@ char *scheme_X_double_to_string (WIDEST_DOUBLE d, char* s, int slen, int was_sin
char *scheme_double_to_string (double d, char* s, int slen, int was_single, int *used_buffer)
{
return scheme_X_double_to_string(d, s, slen, was_single, 0, used_buffer);
long_double stub;
memset(&stub, 0, sizeof(long_double));
return scheme_X_double_to_string(d, s, slen, was_single, 0, used_buffer, stub);
}
static char *double_to_string (WIDEST_DOUBLE d, int alloc, int was_single, int extfl)
static char *double_to_string (double d, int alloc, int was_single, int extfl, long_double ld)
{
char buffer[100];
char *s;
int used_buffer = 0;
s = scheme_X_double_to_string(d, buffer, 100, was_single, extfl, &used_buffer);
s = scheme_X_double_to_string(d, buffer, 100, was_single, extfl, &used_buffer, ld);
if (used_buffer) {
s = (char *)scheme_malloc_atomic(strlen(buffer) + 1);
@ -1892,16 +1901,16 @@ static char *double_to_string (WIDEST_DOUBLE d, int alloc, int was_single, int e
}
#ifdef MZ_LONG_DOUBLE
char *scheme_long_double_to_string (long double d, char* s, int slen, int *used_buffer)
char *scheme_long_double_to_string (long_double ld, char* s, int slen, int *used_buffer)
{
return scheme_X_double_to_string(d, s, slen, 0, 1, used_buffer);
return scheme_X_double_to_string(0.0, s, slen, 0, 1, used_buffer, ld);
}
#endif
static char *number_to_allocated_string(int radix, Scheme_Object *obj, int alloc)
{
char *s;
long_double stub;
if (SCHEME_FLOATP(obj)) {
if (radix != 10)
scheme_contract_error("number->string",
@ -1909,7 +1918,7 @@ static char *number_to_allocated_string(int radix, Scheme_Object *obj, int alloc
"number", 1, obj,
"requested base", 1, scheme_make_integer(radix),
NULL);
s = double_to_string(SCHEME_FLOAT_VAL(obj), alloc, SCHEME_FLTP(obj), 0);
s = double_to_string(SCHEME_FLOAT_VAL(obj), alloc, SCHEME_FLTP(obj), 0, stub);
} else if (SCHEME_LONG_DBLP(obj)) {
if (radix != 10)
scheme_contract_error("number->string",
@ -1918,7 +1927,7 @@ static char *number_to_allocated_string(int radix, Scheme_Object *obj, int alloc
"requested base", 1, scheme_make_integer(radix),
NULL);
#ifdef MZ_LONG_DOUBLE
s = double_to_string(SCHEME_LONG_DBL_VAL(obj), alloc, 0, 1);
s = double_to_string(0.0, alloc, 0, 1, SCHEME_LONG_DBL_VAL(obj));
#else
s = (char *)((Scheme_Long_Double *)obj)->printed_form;
#endif
@ -1996,7 +2005,7 @@ int scheme_check_double(const char *where, double d, const char *dest)
}
#ifdef MZ_LONG_DOUBLE
int scheme_check_long_double(const char *where, long double d, const char *dest)
int scheme_check_long_double(const char *where, long_double d, const char *dest)
{
if (MZ_IS_LONG_INFINITY(d)
|| MZ_IS_LONG_NAN(d)) {
@ -2504,9 +2513,9 @@ static Scheme_Object *bytes_to_long_double (int argc, Scheme_Object *argv[])
{
#ifdef MZ_LONG_DOUBLE
intptr_t offset = 0, slen;
char *str, buf[sizeof(long double)];
char *str, buf[sizeof(long_double)];
int bigend = MZ_IS_BIG_ENDIAN;
long double d;
long_double d;
if (!SCHEME_BYTE_STRINGP(argv[0]))
scheme_wrong_contract("floating-point-bytes->extfl", "bytes?", 0, argc, argv);
@ -2562,7 +2571,7 @@ static Scheme_Object *long_double_to_bytes (int argc, Scheme_Object *argv[])
Scheme_Object *n, *s;
int size = LONG_DOUBLE_BYTE_LEN;
int bigend = MZ_IS_BIG_ENDIAN;
long double d;
long_double d;
intptr_t offset = 0;
n = argv[0];

14
src/racket/src/optimize.c
View File

@ -2624,8 +2624,8 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz
return scheme_make_double(0.0);
}
#ifdef MZ_LONG_DOUBLE
z1 = (SCHEME_LONG_DBLP(app->rand1) && (SCHEME_LONG_DBL_VAL(app->rand1) == 0.0L));
z2 = (SCHEME_LONG_DBLP(app->rand2) && (SCHEME_LONG_DBL_VAL(app->rand2) == 0.0L));
z1 = (SCHEME_LONG_DBLP(app->rand1) && long_double_is_zero(SCHEME_LONG_DBL_VAL(app->rand1)));
z2 = (SCHEME_LONG_DBLP(app->rand2) && long_double_is_zero(SCHEME_LONG_DBL_VAL(app->rand2)));
if (IS_NAMED_PRIM(app->rator, "unsafe-extfl+")) {
if (z1)
@ -2636,17 +2636,17 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz
if (z2)
return app->rand1;
} else if (IS_NAMED_PRIM(app->rator, "unsafe-extfl*")) {
if (SCHEME_LONG_DBLP(app->rand1) && (SCHEME_LONG_DBL_VAL(app->rand1) == 1.0L))
if (SCHEME_LONG_DBLP(app->rand1) && long_double_is_1(SCHEME_LONG_DBL_VAL(app->rand1)))
return app->rand2;
if (SCHEME_LONG_DBLP(app->rand2) && (SCHEME_LONG_DBL_VAL(app->rand2) == 1.0L))
if (SCHEME_LONG_DBLP(app->rand2) && long_double_is_1(SCHEME_LONG_DBL_VAL(app->rand2)))
return app->rand1;
} else if (IS_NAMED_PRIM(app->rator, "unsafe-extfl/")) {
if (SCHEME_LONG_DBLP(app->rand2) && (SCHEME_LONG_DBL_VAL(app->rand2) == 1.0L))
if (SCHEME_LONG_DBLP(app->rand2) && long_double_is_1(SCHEME_LONG_DBL_VAL(app->rand2)))
return app->rand1;
} else if (IS_NAMED_PRIM(app->rator, "unsafe-extflremainder")
|| IS_NAMED_PRIM(app->rator, "unsafe-extflmodulo")) {
if (SCHEME_LONG_DBLP(app->rand2) && (SCHEME_LONG_DBL_VAL(app->rand2) == 1.0L))
return scheme_make_long_double(0.0L);
if (SCHEME_LONG_DBLP(app->rand2) && long_double_is_1(SCHEME_LONG_DBL_VAL(app->rand2)))
return scheme_make_long_double(get_long_double_zero());
}
#endif
}

42
src/racket/src/ratfloat.inc
View File

@ -5,10 +5,10 @@
floating-point optimizations in the rest of the program, so we used
a little function to defeat the optimization. This is almost
certainly not necessary anymore. */
FP_TYPE DO_FLOAT_DIV(FP_TYPE n, FP_TYPE d)
{
return n / d;
return FP_DIV(n, d);
}
#ifndef FP_ZEROx
@ -17,6 +17,7 @@ FP_TYPE DO_FLOAT_DIV(FP_TYPE n, FP_TYPE d)
# define FP_MODFx modf
# define FP_FREXPx frexp
# define FP_DOUBLE_TYPE double
# define FP_LDEXP ldexp
#endif
FP_TYPE SCHEME_RATIONAL_TO_FLOAT(const Scheme_Object *o)
@ -26,13 +27,17 @@ FP_TYPE SCHEME_RATIONAL_TO_FLOAT(const Scheme_Object *o)
intptr_t ns, ds;
if (SCHEME_INTP(r->num)) {
n = (FP_TYPE)SCHEME_INT_VAL(r->num);
#ifdef CONVERT_INT_TO_FLOAT
n = CONVERT_INT_TO_FLOAT(SCHEME_INT_VAL(r->num));
#else
n = FP_TYPE_FROM_INT(SCHEME_INT_VAL(r->num));
#endif
ns = 0;
} else
n = SCHEME_BIGNUM_TO_FLOAT_INF_INFO(r->num, 0, &ns);
if (SCHEME_INTP(r->denom)) {
d = (FP_TYPE)SCHEME_INT_VAL(r->denom);
d = FP_TYPE_FROM_INT(SCHEME_INT_VAL(r->denom));
ds = 0;
} else
d = SCHEME_BIGNUM_TO_FLOAT_INF_INFO(r->denom, 0, &ds);
@ -87,17 +92,17 @@ FP_TYPE SCHEME_RATIONAL_TO_FLOAT(const Scheme_Object *o)
n = scheme_rational_round(n);
if (SCHEME_INTP(n))
res = (FP_TYPE)SCHEME_INT_VAL(n);
res = FP_TYPE_FROM_INT(SCHEME_INT_VAL(n));
else
res = SCHEME_BIGNUM_TO_FLOAT_INF_INFO(n, 0, NULL);
res = res * FP_POWx(2, p - shift);
res = FP_MULT(res, FP_TYPE_FROM_INT(FP_POWx(2, p - shift)));
if (SCHEME_INTP(r->num)) {
if (SCHEME_INT_VAL(r->num) < 0)
res = -res;
res = FP_NEG(res);
} else if (!SCHEME_BIGPOS(r->num)) {
res = -res;
res = FP_NEG(res);
}
return res;
@ -122,14 +127,14 @@ Scheme_Object *SCHEME_RATIONAL_FROM_FLOAT(FP_TYPE d)
SCHEME_CHECK_FLOAT("inexact->exact", d, "exact");
is_neg = (d < FP_ZEROx);
is_neg = FP_LESS(d, FP_ZEROx);
frac = FP_MODFx((FP_DOUBLE_TYPE)d, &i);
frac = FP_MODFx(d, &i);
(void)FP_FREXPx(d, &exponent);
int_part = SCHEME_BIGNUM_FROM_FLOAT(i);
if (!frac) {
if (FP_EQV(frac, FP_ZEROx)) {
#ifdef COMPUTE_NEG_INEXACT_TO_EXACT_AS_POS
if (negate)
return scheme_bin_minus(scheme_make_integer(0), int_part);
@ -142,12 +147,12 @@ Scheme_Object *SCHEME_RATIONAL_FROM_FLOAT(FP_TYPE d)
two = scheme_make_integer(2);
count = 0;
while (frac) {
while (!FP_EQV(frac, FP_ZEROx)) {
count++;
frac_num = scheme_bin_mult(frac_num, two);
frac_denom = scheme_bin_mult(frac_denom, two);
frac = FP_MODFx(ldexp(frac, 1), &i);
if (i) {
frac = FP_MODFx(FP_LDEXP(frac, 1), &i);
if (!FP_IS_ZERO(i)) {
if (is_neg)
frac_num = scheme_bin_minus(frac_num, one);
else
@ -181,3 +186,12 @@ Scheme_Object *SCHEME_RATIONAL_FROM_FLOAT(FP_TYPE d)
#undef FP_MODFx
#undef FP_FREXPx
#undef FP_DOUBLE_TYPE
#undef FP_MULT
#undef FP_DIV
#undef FP_NEG
#undef FP_LESS
#undef FP_TYPE_FROM_INT
#undef FP_LDEXP
#undef FP_EQV
#undef FP_IS_ZERO

33
src/racket/src/rational.c
View File

@ -516,6 +516,13 @@ Scheme_Object *scheme_rational_sqrt(const Scheme_Object *o)
}
#define FP_TYPE double
#define FP_MULT(x, y) x*y
#define FP_DIV(x, y) x/y
#define FP_NEG(x) -x
#define FP_EQV(x,y) x==y
#define FP_LESS(x, y) x<y
#define FP_IS_ZERO(x) x==0.0
#define FP_TYPE_FROM_INT(x) (FP_TYPE)x
#define SCHEME_RATIONAL_TO_FLOAT scheme_rational_to_double
#define SCHEME_RATIONAL_FROM_FLOAT scheme_rational_from_double
#define SCHEME_BIGNUM_TO_FLOAT_INF_INFO scheme_bignum_to_double_inf_info
@ -528,6 +535,13 @@ Scheme_Object *scheme_rational_sqrt(const Scheme_Object *o)
#ifdef MZ_USE_SINGLE_FLOATS
#define FP_TYPE float
#define FP_MULT(x, y) x*y
#define FP_DIV(x, y) x/y
#define FP_NEG(x) -x
#define FP_EQV(x,y) x==y
#define FP_LESS(x, y) x<y
#define FP_TYPE_FROM_INT(x) (FP_TYPE)x
#define FP_IS_ZERO(x) x==0.0
#define SCHEME_RATIONAL_TO_FLOAT scheme_rational_to_float
#define SCHEME_RATIONAL_FROM_FLOAT scheme_rational_from_float
#define SCHEME_BIGNUM_TO_FLOAT_INF_INFO scheme_bignum_to_float_inf_info
@ -540,19 +554,26 @@ Scheme_Object *scheme_rational_sqrt(const Scheme_Object *o)
#endif
#ifdef MZ_LONG_DOUBLE
# define FP_TYPE long double
# define FP_TYPE long_double
# define FP_MULT(x, y) long_double_mult(x,y)
# define FP_DIV(x, y) long_double_div(x,y)
# define FP_NEG(x) long_double_neg(x)
# define FP_EQV(x,y) long_double_eqv(x,y)
# define FP_LESS(x, y) long_double_less(x,y)
# define FP_TYPE_FROM_INT(x) long_double_from_int(x)
# define FP_IS_ZERO(x) long_double_is_zero(x)
# define SCHEME_RATIONAL_TO_FLOAT scheme_rational_to_long_double
# define SCHEME_RATIONAL_FROM_FLOAT scheme_rational_from_long_double
# define SCHEME_BIGNUM_TO_FLOAT_INF_INFO scheme_bignum_to_long_double_inf_info
# define SCHEME_CHECK_FLOAT scheme_check_long_double
# define SCHEME_BIGNUM_FROM_FLOAT scheme_bignum_from_long_double
# define DO_FLOAT_DIV scheme__do_long_double_div
# define FLOAT_E_MIN -16383
# define FLOAT_M_BITS 64
# define FP_ZEROx 0L
# define FP_POWx powl
# define FP_MODFx modfl
# define FP_FREXPx frexpl
# define FP_ZEROx get_long_double_zero()
# define FP_POWx pow
# define FP_MODFx long_double_modf
# define FP_FREXPx long_double_frexp
# define FP_LDEXP long_double_ldexp
# define FP_DOUBLE_TYPE FP_TYPE
#include "ratfloat.inc"
#endif

14
src/racket/src/schemef.h
View File

@ -34,7 +34,7 @@
/*========================================================================*/
/* setjmpup (continuations) */
/*========================================================================*/
#include "longdouble/longdouble.h"
MZ_EXTERN void scheme_init_jmpup_buf(Scheme_Jumpup_Buf *b);
MZ_EXTERN int scheme_setjmpup_relative(Scheme_Jumpup_Buf *b, void *base,
void * volatile start, struct Scheme_Cont *cont);
@ -619,7 +619,7 @@ MZ_EXTERN Scheme_Object *scheme_make_integer_value_from_long_halves(uintptr_t lo
MZ_EXTERN Scheme_Object *scheme_make_integer_value_from_unsigned_long_halves(uintptr_t lowhalf, uintptr_t hihalf);
MZ_EXTERN Scheme_Object *scheme_make_double(double d);
#ifdef MZ_LONG_DOUBLE
MZ_EXTERN Scheme_Object *scheme_make_long_double(long double d);
MZ_EXTERN Scheme_Object *scheme_make_long_double(long_double d);
#endif
#ifdef MZ_USE_SINGLE_FLOATS
MZ_EXTERN Scheme_Object *scheme_make_float(float f) ;
@ -643,7 +643,7 @@ XFORM_NONGCING MZ_EXTERN int scheme_get_unsigned_long_long_val(Scheme_Object *o,
MZ_EXTERN double scheme_real_to_double(Scheme_Object *r);
#ifdef MZ_LONG_DOUBLE
MZ_EXTERN long double scheme_real_to_long_double(Scheme_Object *r);
MZ_EXTERN long_double scheme_real_to_long_double(Scheme_Object *r);
#endif
MZ_EXTERN Scheme_Object *scheme_make_cptr(void *cptr, Scheme_Object *typetag);
@ -707,8 +707,8 @@ MZ_EXTERN Scheme_Object *scheme_make_bignum_from_unsigned_long_long(umzlonglong
XFORM_NONGCING MZ_EXTERN double scheme_bignum_to_double(const Scheme_Object *n);
MZ_EXTERN Scheme_Object *scheme_bignum_from_double(double d);
#ifdef MZ_LONG_DOUBLE
XFORM_NONGCING MZ_EXTERN long double scheme_bignum_to_long_double(const Scheme_Object *n);
MZ_EXTERN Scheme_Object *scheme_bignum_from_long_double(long double d);
XFORM_NONGCING MZ_EXTERN long_double scheme_bignum_to_long_double(const Scheme_Object *n);
MZ_EXTERN Scheme_Object *scheme_bignum_from_long_double(long_double d);
#endif
#ifdef MZ_USE_SINGLE_FLOATS
XFORM_NONGCING MZ_EXTERN float scheme_bignum_to_float(const Scheme_Object *n);
@ -731,8 +731,8 @@ MZ_EXTERN Scheme_Object *scheme_make_rational(const Scheme_Object *r, const Sche
MZ_EXTERN double scheme_rational_to_double(const Scheme_Object *n);
MZ_EXTERN Scheme_Object *scheme_rational_from_double(double d);
#ifdef MZ_LONG_DOUBLE
MZ_EXTERN long double scheme_rational_to_long_double(const Scheme_Object *n);
MZ_EXTERN Scheme_Object *scheme_rational_from_long_double(long double d);
MZ_EXTERN long_double scheme_rational_to_long_double(const Scheme_Object *n);
MZ_EXTERN Scheme_Object *scheme_rational_from_long_double(long_double d);
#endif
#ifdef MZ_USE_SINGLE_FLOATS
MZ_EXTERN float scheme_rational_to_float(const Scheme_Object *n);

13
src/racket/src/schemex.h
View File

@ -16,6 +16,7 @@ typedef struct {
/*========================================================================*/
/* setjmpup (continuations) */
/*========================================================================*/
#include "longdouble/longdouble.h"
void (*scheme_init_jmpup_buf)(Scheme_Jumpup_Buf *b);
int (*scheme_setjmpup_relative)(Scheme_Jumpup_Buf *b, void *base,
void * volatile start, struct Scheme_Cont *cont);
@ -497,7 +498,7 @@ Scheme_Object *(*scheme_make_integer_value_from_long_halves)(uintptr_t lowhalf,
Scheme_Object *(*scheme_make_integer_value_from_unsigned_long_halves)(uintptr_t lowhalf, uintptr_t hihalf);
Scheme_Object *(*scheme_make_double)(double d);
#ifdef MZ_LONG_DOUBLE
Scheme_Object *(*scheme_make_long_double)(long double d);
Scheme_Object *(*scheme_make_long_double)(long_double d);
#endif
#ifdef MZ_USE_SINGLE_FLOATS
Scheme_Object *(*scheme_make_float)(float f) ;
@ -518,7 +519,7 @@ int (*scheme_get_long_long_val)(Scheme_Object *o, mzlonglong *v);
int (*scheme_get_unsigned_long_long_val)(Scheme_Object *o, umzlonglong *v);
double (*scheme_real_to_double)(Scheme_Object *r);
#ifdef MZ_LONG_DOUBLE
long double;
long_double (*scheme_real_to_long_double)(Scheme_Object *r);
#endif
Scheme_Object *(*scheme_make_cptr)(void *cptr, Scheme_Object *typetag);
Scheme_Object *(*scheme_make_offset_cptr)(void *cptr, intptr_t offset, Scheme_Object *typetag);
@ -571,8 +572,8 @@ Scheme_Object *(*scheme_make_bignum_from_unsigned_long_long)(umzlonglong v);
double (*scheme_bignum_to_double)(const Scheme_Object *n);
Scheme_Object *(*scheme_bignum_from_double)(double d);
#ifdef MZ_LONG_DOUBLE
long double;
Scheme_Object *(*scheme_bignum_from_long_double)(long double d);
long_double (*scheme_bignum_to_long_double)(const Scheme_Object *n);
Scheme_Object *(*scheme_bignum_from_long_double)(long_double d);
#endif
#ifdef MZ_USE_SINGLE_FLOATS
float (*scheme_bignum_to_float)(const Scheme_Object *n);
@ -593,8 +594,8 @@ Scheme_Object *(*scheme_make_rational)(const Scheme_Object *r, const Scheme_Obje
double (*scheme_rational_to_double)(const Scheme_Object *n);
Scheme_Object *(*scheme_rational_from_double)(double d);
#ifdef MZ_LONG_DOUBLE
long double;
Scheme_Object *(*scheme_rational_from_long_double)(long double d);
long_double (*scheme_rational_to_long_double)(const Scheme_Object *n);
Scheme_Object *(*scheme_rational_from_long_double)(long_double d);
#endif
#ifdef MZ_USE_SINGLE_FLOATS
float (*scheme_rational_to_float)(const Scheme_Object *n);

82
src/racket/src/schpriv.h
View File

@ -19,6 +19,7 @@
#define __mzscheme_private__
#include "scheme.h"
#include "longdouble/longdouble.h"
#ifdef CIL_ANALYSIS
#define ROSYM __attribute__((__ROSYM__))
@ -1864,6 +1865,23 @@ intptr_t scheme_get_semaphore_init(const char *who, int n, Scheme_Object **p);
# define MZ_LONG_DOUBLE_AND(x) 0
#endif
#ifdef MZ_LONG_DOUBLE_API_IS_EXTERNAL
# define MZ_LONG_DOUBLE_AVAIL_AND(x) MZ_LONG_DOUBLE_AND(long_double_available() && (x))
# define WHEN_LONG_DOUBLE_UNSUPPORTED(what) \
if (!long_double_available()) { \
what; \
}
# define CHECK_MZ_LONG_DOUBLE_UNSUPPORTED(who) \
if (!long_double_available()) { \
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, who ": " NOT_SUPPORTED_STR); \
ESCAPED_BEFORE_HERE; \
}
#else
# define WHEN_LONG_DOUBLE_UNSUPPORTED(what) /* empty */
# define CHECK_MZ_LONG_DOUBLE_UNSUPPORTED(who) /* empty */
# define MZ_LONG_DOUBLE_AVAIL_AND(x) MZ_LONG_DOUBLE_AND(x)
#endif
void scheme_configure_floating_point(void);
/****** Bignums *******/
@ -1902,7 +1920,7 @@ XFORM_NONGCING Scheme_Object *scheme_make_small_bignum(intptr_t v, Small_Bignum
char *scheme_number_to_string(int radix, Scheme_Object *obj);
char *scheme_double_to_string (double d, char* s, int slen, int was_single, int *used_buffer);
#ifdef MZ_LONG_DOUBLE
char *scheme_long_double_to_string (long double d, char* s, int slen, int *used_buffer);
char *scheme_long_double_to_string (long_double d, char* s, int slen, int *used_buffer);
#endif
Scheme_Object *scheme_bignum_copy(const Scheme_Object *n);
@ -1939,7 +1957,7 @@ Scheme_Object *scheme_bignum_shift(const Scheme_Object *a, intptr_t shift);
XFORM_NONGCING double scheme_bignum_to_double_inf_info(const Scheme_Object *n, intptr_t just_use, intptr_t *only_need);
#ifdef MZ_LONG_DOUBLE
XFORM_NONGCING long double scheme_bignum_to_long_double_inf_info(const Scheme_Object *n, intptr_t just_use, intptr_t *only_need);
XFORM_NONGCING long_double scheme_bignum_to_long_double_inf_info(const Scheme_Object *n, intptr_t just_use, intptr_t *only_need);
#endif
#ifdef MZ_USE_SINGLE_FLOATS
XFORM_NONGCING float scheme_bignum_to_float_inf_info(const Scheme_Object *n, intptr_t just_use, intptr_t *only_need);
@ -2023,7 +2041,7 @@ XFORM_NONGCING int scheme_is_complex_exact(const Scheme_Object *o);
int scheme_check_double(const char *where, double v, const char *dest);
#ifdef MZ_LONG_DOUBLE
int scheme_check_long_double(const char *where, long double v, const char *dest);
int scheme_check_long_double(const char *where, long_double v, const char *dest);
#endif
#ifdef MZ_USE_SINGLE_FLOATS
int scheme_check_float(const char *where, float v, const char *dest);
@ -2035,8 +2053,8 @@ double scheme_get_val_as_double(const Scheme_Object *n);
XFORM_NONGCING int scheme_minus_zero_p(double d);
#ifdef MZ_LONG_DOUBLE
long double scheme_get_val_as_long_double(const Scheme_Object *n);
XFORM_NONGCING int scheme_long_minus_zero_p(long double d);
long_double scheme_get_val_as_long_double(const Scheme_Object *n);
XFORM_NONGCING int scheme_long_minus_zero_p(long_double d);
#else
# define scheme_long_minus_zero_p(d) scheme_minus_zero_p(d)
#endif
@ -2107,10 +2125,17 @@ extern int scheme_is_nan(double);
# endif
#endif
#define MZ_IS_LONG_INFINITY(d) MZ_IS_INFINITY(d)
#define MZ_IS_LONG_POS_INFINITY(d) MZ_IS_POS_INFINITY(d)
#define MZ_IS_LONG_NEG_INFINITY(d) MZ_IS_NEG_INFINITY(d)
#define MZ_IS_LONG_NAN(d) MZ_IS_NAN(d)
#ifdef MZ_LONG_DOUBLE_API_IS_EXTERNAL
# define MZ_IS_LONG_INFINITY(d) long_double_is_infinity(d)
# define MZ_IS_LONG_POS_INFINITY(d) long_double_is_pos_infinity(d)
# define MZ_IS_LONG_NEG_INFINITY(d) long_double_is_neg_infinity(d)
# define MZ_IS_LONG_NAN(d) long_double_is_nan(d)
#else
# define MZ_IS_LONG_INFINITY(d) MZ_IS_INFINITY(d)
# define MZ_IS_LONG_POS_INFINITY(d) MZ_IS_POS_INFINITY(d)
# define MZ_IS_LONG_NEG_INFINITY(d) MZ_IS_NEG_INFINITY(d)
# define MZ_IS_LONG_NAN(d) MZ_IS_NAN(d)
#endif
#ifndef MZ_IS_INFINITY
# define MZ_IS_INFINITY(d) (MZ_IS_POS_INFINITY(d) || MZ_IS_NEG_INFINITY(d))
@ -2124,9 +2149,9 @@ extern double scheme_floating_point_nzero;
extern Scheme_Object *scheme_zerod, *scheme_nzerod, *scheme_pi, *scheme_half_pi, *scheme_plus_i, *scheme_minus_i;
extern Scheme_Object *scheme_inf_object, *scheme_minus_inf_object, *scheme_nan_object;
#ifdef MZ_LONG_DOUBLE
extern long double scheme_long_infinity_val, scheme_long_minus_infinity_val;
extern long double scheme_long_floating_point_zero;
extern long double scheme_long_floating_point_nzero;
extern long_double scheme_long_infinity_val, scheme_long_minus_infinity_val;
extern long_double scheme_long_floating_point_zero;
extern long_double scheme_long_floating_point_nzero;
extern Scheme_Object *scheme_zerol, *scheme_nzerol, *scheme_long_scheme_pi;
extern Scheme_Object *scheme_long_inf_object, *scheme_long_minus_inf_object, *scheme_long_nan_object;
#endif
@ -2238,19 +2263,19 @@ double scheme_double_expt(double x, double y);
/***** extflonums *****/
#ifdef MZ_LONG_DOUBLE
long double scheme_long_double_truncate(long double x);
long double scheme_long_double_round(long double x);
long double scheme_long_double_floor(long double x);
long double scheme_long_double_ceiling(long double x);
long double scheme_long_double_sin(long double x);
long double scheme_long_double_cos(long double x);
long double scheme_long_double_tan(long double x);
long double scheme_long_double_asin(long double x);
long double scheme_long_double_acos(long double x);
long double scheme_long_double_atan(long double x);
long double scheme_long_double_log(long double x);
long double scheme_long_double_exp(long double x);
long double scheme_long_double_expt(long double x, long double y);
long_double scheme_long_double_truncate(long_double x);
long_double scheme_long_double_round(long_double x);
long_double scheme_long_double_floor(long_double x);
long_double scheme_long_double_ceiling(long_double x);
long_double scheme_long_double_sin(long_double x);
long_double scheme_long_double_cos(long_double x);
long_double scheme_long_double_tan(long_double x);
long_double scheme_long_double_asin(long_double x);
long_double scheme_long_double_acos(long_double x);
long_double scheme_long_double_atan(long_double x);
long_double scheme_long_double_log(long_double x);
long_double scheme_long_double_exp(long_double x);
long_double scheme_long_double_expt(long_double x, long_double y);
#endif
/*========================================================================*/
/* read, eval, print */
@ -2569,7 +2594,7 @@ typedef struct Scheme_Current_LWC {
void *saved_v1;
double saved_save_fp;
#ifdef MZ_LONG_DOUBLE
long double saved_save_extfp;
long_double saved_save_extfp;
#endif
} Scheme_Current_LWC;
@ -3630,6 +3655,11 @@ void scheme_write_proc_context(Scheme_Object *port, int print_width,
int scheme_is_relative_path(const char *s, intptr_t len, int kind);
int scheme_is_complete_path(const char *s, intptr_t len, int kind);
#ifdef DOS_FILE_SYSTEM
__declspec(dllexport) wchar_t *scheme_get_dll_path(wchar_t *s);
__declspec(dllexport) void scheme_set_dll_path(wchar_t *p);
#endif
Scheme_Object *scheme_get_file_directory(const char *filename);
char *scheme_normal_path_seps(char *s, int *_len, int delta);

1
src/racket/src/string.c
View File

@ -79,7 +79,6 @@ static int get_iconv_errno(void)
# define HAVE_CODESET 1
# define CODESET 0
# define ICONV_errno get_iconv_errno()
extern wchar_t *scheme_get_dll_path(wchar_t *s);
static int iconv_ready = 0;
static void init_iconv()
{

4
src/worksp/README
View File

@ -139,6 +139,10 @@ pango-1.28.3:
modules/basic/basic-win32.c:479:
if (ScriptItemize (wtext, wlen, G_N_ELEMENTS (items) - 1, &control, NULL,
The "longdouble.dll" library is used to implement extflonums. Its
source is "longdouble.c" in the Racket source directory, and it must
be compiled using MinGW and with `IMPLEMENTING_MSC_LONGDOUBLE' defined.
Building Racket3m and GRacket3m
-------------------------------