diff --git a/collects/compiler/distribute.rkt b/collects/compiler/distribute.rkt index 1a021032c0..699ca8ee36 100644 --- a/collects/compiler/distribute.rkt +++ b/collects/compiler/distribute.rkt @@ -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 diff --git a/collects/scribblings/reference/extflonums.scrbl b/collects/scribblings/reference/extflonums.scrbl index 19eb35e2be..89c8188b14 100644 --- a/collects/scribblings/reference/extflonums.scrbl +++ b/collects/scribblings/reference/extflonums.scrbl @@ -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 diff --git a/src/README b/src/README index fb27b235df..6e4195439a 100644 --- a/src/README +++ b/src/README @@ -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 --------------------- diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 4a242ae881..8e75e53f8e 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -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() */ +#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() */ + /* 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; diff --git a/src/foreign/foreign.rktc b/src/foreign/foreign.rktc index 6297ae7a72..0d5333adfc 100755 --- a/src/foreign/foreign.rktc +++ b/src/foreign/foreign.rktc @@ -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 || @; diff --git a/src/get-libs.rkt b/src/get-libs.rkt index cf888b5d99..ee0fd69321 100644 --- a/src/get-libs.rkt +++ b/src/get-libs.rkt @@ -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 diff --git a/src/racket/include/scheme.h b/src/racket/include/scheme.h index 5753d980c9..66b6eb9a18 100644 --- a/src/racket/include/scheme.h +++ b/src/racket/include/scheme.h @@ -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 diff --git a/src/racket/include/schthread.h b/src/racket/include/schthread.h index 61e3e639bb..22a43bab1d 100644 --- a/src/racket/include/schthread.h +++ b/src/racket/include/schthread.h @@ -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_; diff --git a/src/racket/main.c b/src/racket/main.c index af44ee2bad..b41c0e22f8 100644 --- a/src/racket/main.c +++ b/src/racket/main.c @@ -1,3 +1,4 @@ + /* Racket Copyright (c) 2004-2013 PLT Design Inc. diff --git a/src/racket/sconfig.h b/src/racket/sconfig.h index db27703c8e..e90093295d 100644 --- a/src/racket/sconfig.h +++ b/src/racket/sconfig.h @@ -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 diff --git a/src/racket/src/Makefile.in b/src/racket/src/Makefile.in index cc68ce28b4..5a3d11bf0a 100644 --- a/src/racket/src/Makefile.in +++ b/src/racket/src/Makefile.in @@ -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 \ diff --git a/src/racket/src/bgnfloat.inc b/src/racket/src/bgnfloat.inc index 3cc391b0b9..bd07924ae9 100644 --- a/src/racket/src/bgnfloat.inc +++ b/src/racket/src/bgnfloat.inc @@ -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 diff --git a/src/racket/src/bignum.c b/src/racket/src/bignum.c index f707bd16a9..132a66255f 100644 --- a/src/racket/src/bignum.c +++ b/src/racket/src/bignum.c @@ -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" diff --git a/src/racket/src/bool.c b/src/racket/src/bool.c index 0310ea0922..2820636f73 100644 --- a/src/racket/src/bool.c +++ b/src/racket/src/bool.c @@ -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; } diff --git a/src/racket/src/env.c b/src/racket/src/env.c index 92aad403f0..3e6ce1e99f 100644 --- a/src/racket/src/env.c +++ b/src/racket/src/env.c @@ -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(); diff --git a/src/racket/src/file.c b/src/racket/src/file.c index 74b3c7f2cb..aab6cc435c 100644 --- a/src/racket/src/file.c +++ b/src/racket/src/file.c @@ -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) { diff --git a/src/racket/src/hash.c b/src/racket/src/hash.c index c6a8247b0a..d861671dbc 100644 --- a/src/racket/src/hash.c +++ b/src/racket/src/hash.c @@ -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) diff --git a/src/racket/src/jit.c b/src/racket/src/jit.c index 17846da62d..e2d5ca49f0 100644 --- a/src/racket/src/jit.c +++ b/src/racket/src/jit.c @@ -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); diff --git a/src/racket/src/jit.h b/src/racket/src/jit.h index 7681c64a86..e091d00d62 100644 --- a/src/racket/src/jit.h +++ b/src/racket/src/jit.h @@ -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); diff --git a/src/racket/src/jitalloc.c b/src/racket/src/jitalloc.c index c2b2821f34..e780092eee 100644 --- a/src/racket/src/jitalloc.c +++ b/src/racket/src/jitalloc.c @@ -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) { diff --git a/src/racket/src/jitarith.c b/src/racket/src/jitarith.c index 31e1ccc718..8ed3bb9cdf 100644 --- a/src/racket/src/jitarith.c +++ b/src/racket/src/jitarith.c @@ -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 diff --git a/src/racket/src/jitinline.c b/src/racket/src/jitinline.c index 71001eb3bc..8b380bf24d 100644 --- a/src/racket/src/jitinline.c +++ b/src/racket/src/jitinline.c @@ -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, diff --git a/src/racket/src/jitstate.c b/src/racket/src/jitstate.c index 3350f90cd8..3880e7906f 100644 --- a/src/racket/src/jitstate.c +++ b/src/racket/src/jitstate.c @@ -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++; diff --git a/src/racket/src/lightning/i386/asm.h b/src/racket/src/lightning/i386/asm.h index 0b1198a10c..0e942823bd 100644 --- a/src/racket/src/lightning/i386/asm.h +++ b/src/racket/src/lightning/i386/asm.h @@ -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)) : \ diff --git a/src/racket/src/lightning/i386/fp-extfpu.h b/src/racket/src/lightning/i386/fp-extfpu.h index 016dccb5a4..5fd5078289 100644 --- a/src/racket/src/lightning/i386/fp-extfpu.h +++ b/src/racket/src/lightning/i386/fp-extfpu.h @@ -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 diff --git a/src/racket/src/longdouble/longdouble.c b/src/racket/src/longdouble/longdouble.c new file mode 100644 index 0000000000..f8e51cafb3 --- /dev/null +++ b/src/racket/src/longdouble/longdouble.c @@ -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 +#include "longdouble.h" +#include +#include +#include + +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 diff --git a/src/racket/src/longdouble/longdouble.h b/src/racket/src/longdouble/longdouble.h new file mode 100644 index 0000000000..c455ee5433 --- /dev/null +++ b/src/racket/src/longdouble/longdouble.h @@ -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 diff --git a/src/racket/src/numarith.c b/src/racket/src/numarith.c index 7d6920a429..ba2dffba7d 100644 --- a/src/racket/src/numarith.c +++ b/src/racket/src/numarith.c @@ -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) diff --git a/src/racket/src/number.c b/src/racket/src/number.c index 2821ef272c..a1692629e4 100644 --- a/src/racket/src/number.c +++ b/src/racket/src/number.c @@ -25,6 +25,7 @@ #include "schpriv.h" #include "nummacs.h" +#include "longdouble/longdouble.h" #include #include #include @@ -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 diff --git a/src/racket/src/numcomp.c b/src/racket/src/numcomp.c index 38e4b6e2df..c225c54ff5 100644 --- a/src/racket/src/numcomp.c +++ b/src/racket/src/numcomp.c @@ -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) diff --git a/src/racket/src/numstr.c b/src/racket/src/numstr.c index 8a89cf19eb..ffc9abf26f 100644 --- a/src/racket/src/numstr.c +++ b/src/racket/src/numstr.c @@ -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]; diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index 1196fb975d..e004407633 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -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 } diff --git a/src/racket/src/ratfloat.inc b/src/racket/src/ratfloat.inc index c7df57a63d..a0f32fd70d 100644 --- a/src/racket/src/ratfloat.inc +++ b/src/racket/src/ratfloat.inc @@ -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 \ No newline at end of file diff --git a/src/racket/src/rational.c b/src/racket/src/rational.c index ba4f2d15e7..9901369836 100644 --- a/src/racket/src/rational.c +++ b/src/racket/src/rational.c @@ -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