[racket-dev] [plt] Push #26475: master branch updated
This breaks on Linux 32-bit.
Here's the error I get:
make[7]: Entering directory `/home/stamourv/tmp/tmp-plt/plt/src/build/foreign'
gcc -g -O2 -Wall -pthread -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -I./../racket -I../../foreign/../racket/include -I../../foreign/../racket/src -c ../../foreign/foreign.c -o foreign.o
../../foreign/foreign.c:803: error: expected ‘=’, ‘,’, ‘;’, ‘asm’ or ‘__attribute__’ before ‘unsupported_long_double_val’
../../foreign/foreign.c:971: error: expected specifier-qualifier-list before ‘mz_long_double’
../../foreign/foreign.c: In function ‘ctype_sizeof’:
../../foreign/foreign.c:1119: error: ‘mz_long_double’ undeclared (first use in this function)
../../foreign/foreign.c:1119: error: (Each undeclared identifier is reported only once
../../foreign/foreign.c:1119: error: for each function it appears in.)
../../foreign/foreign.c: In function ‘SCHEME2C’:
../../foreign/foreign.c:1962: error: ‘mz_long_double’ undeclared (first use in this function)
../../foreign/foreign.c:1962: error: expected ‘;’ before ‘tmp’
../../foreign/foreign.c:1963: error: ‘tmp’ undeclared (first use in this function)
../../foreign/foreign.c:1963: warning: implicit declaration of function ‘unsupported_long_double_val’
../../foreign/foreign.c:1964: error: expected expression before ‘)’ token
../../foreign/foreign.c: In function ‘foreign_compiler_sizeof’:
../../foreign/foreign.c:2340: error: ‘mz_long_double’ undeclared (first use in this function)
../../foreign/foreign.c:2340: error: expected expression before ‘)’ token
../../foreign/foreign.c: In function ‘finish_ffi_call’:
../../foreign/foreign.c:3109: error: ‘ForeignAny’ has no member named ‘x_pointer’
../../foreign/foreign.c:3118: error: ‘ForeignAny’ has no member named ‘x_pointer’
../../foreign/foreign.c:3118: error: ‘ForeignAny’ has no member named ‘x_pointer’
make[7]: *** [foreign.o] Error 1
Vincent
At Mon, 18 Mar 2013 10:52:14 -0400,
mflatt at racket-lang.org wrote:
>
> mflatt has updated `master' from ccc8b85cef to 35a093469c.
> http://git.racket-lang.org/plt/ccc8b85cef..35a093469c
>
> =====[ One Commit ]=====================================================
> Directory summary:
> 4.7% src/foreign/
> 39.2% src/racket/src/longdouble/
> 53.9% src/racket/src/
>
> ~~~~~~~~~~
>
> 35a0934 Michael Filonenko <filonenko.mikhail at gmail.com> 2013-03-04 19:15:15 +0400
> :
> | windows: extflonum support
> |
> | Enable extflonums in a MSVC build by relying on a MinGW-built DLL,
> | "longdouble.dll". The DLL is loaded on startup. If the DLL isn't
> | available, then `extflonum-available?' reports #f.
> |
> | Instead of setting the floating-point mode globally to extended
> | precision, the mode is changed only just before (and restored right
> | after) extflonum arithmetic operations.
> :
> M collects/compiler/distribute.rkt | 3 +-
> M collects/scribblings/reference/extflonums.scrbl | 3 +-
> M src/README | 4 +
> M src/foreign/foreign.c | 56 ++--
> M src/foreign/foreign.rktc | 41 ++-
> M src/get-libs.rkt | 6 +-
> M src/racket/include/scheme.h | 16 +-
> M src/racket/include/schthread.h | 4 +-
> M src/racket/main.c | 1 +
> M src/racket/sconfig.h | 1 +
> M src/racket/src/Makefile.in | 3 +-
> M src/racket/src/bgnfloat.inc | 37 ++-
> M src/racket/src/bignum.c | 44 ++-
> M src/racket/src/bool.c | 18 +-
> M src/racket/src/env.c | 4 +
> M src/racket/src/file.c | 3 -
> M src/racket/src/hash.c | 25 +-
> M src/racket/src/jitalloc.c | 6 +-
> M src/racket/src/jitarith.c | 33 +-
> M src/racket/src/jit.c | 4 +-
> M src/racket/src/jit.h | 6 +-
> M src/racket/src/jitinline.c | 10 +-
> M src/racket/src/jitstate.c | 4 +-
> M src/racket/src/lightning/i386/asm.h | 4 +
> M src/racket/src/lightning/i386/fp-extfpu.h | 2 +-
> A src/racket/src/longdouble/longdouble.c
> A src/racket/src/longdouble/longdouble.h
> M src/racket/src/numarith.c | 62 ++--
> M src/racket/src/number.c | 361 ++++++++++++---------
> M src/racket/src/numcomp.c | 66 ++--
> M src/racket/src/numstr.c | 135 ++++----
> M src/racket/src/optimize.c | 14 +-
> M src/racket/src/ratfloat.inc | 42 ++-
> M src/racket/src/rational.c | 33 +-
> M src/racket/src/schemef.h | 14 +-
> M src/racket/src/schemex.h | 13 +-
> M src/racket/src/schpriv.h | 82 +++--
> M src/racket/src/string.c | 1 -
> M src/worksp/README | 4 +
>
> =====[ Overall Diff ]===================================================
>
> collects/compiler/distribute.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/compiler/distribute.rkt
> +++ NEW/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
>
> collects/scribblings/reference/extflonums.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/scribblings/reference/extflonums.scrbl
> +++ NEW/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
>
> src/README
> ~~~~~~~~~~
> --- OLD/src/README
> +++ NEW/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
> ---------------------
>
>
> src/foreign/foreign.c
> ~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/foreign/foreign.c
> +++ NEW/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(<C>)
> */
>
> +#ifdef _MSC_VER
> +struct struct_align_slongdouble {
> + char c;
> + long_double x;
> +};
> +const ffi_type ffi_type_slongdouble = {
> + sizeof(long_double),
> + offsetof(struct struct_align_slongdouble, x),
> + FFI_TYPE_STRUCT, NULL
> +};
> +#else /* _MSC_VER undefined */
> #define ffi_type_slongdouble ffi_type_longdouble
> -#ifdef MZ_LONG_DOUBLE
> -typedef long double mz_long_double;
> -#else /* MZ_LONG_DOUBLE undefined */
> -typedef double mz_long_double;
> -#endif /* MZ_LONG_DOUBLE */
> +#endif /* _MSC_VER */
> #ifdef MZ_LONG_DOUBLE
> #define SCHEME_MAYBE_LONG_DBL_VAL(x) SCHEME_LONG_DBL_VAL(x)
> #else /* MZ_LONG_DOUBLE undefined */
> @@ -804,6 +814,7 @@ static Scheme_Object *unsupported_make_long_double() {
> return NULL;
> }
> #endif /* MZ_LONG_DOUBLE */
> +
> #define FOREIGN_longdouble (16)
> /* Type Name: longdouble
> * LibFfi type: ffi_type_slongdouble
> @@ -814,6 +825,7 @@ static Scheme_Object *unsupported_make_long_double() {
> * C->Racket: scheme_make_maybe_long_double(<C>)
> */
>
> +
> /* A double that will coerce numbers to doubles: */
> #define FOREIGN_doubleS (17)
> /* Type Name: double* (doubleS)
> @@ -1858,7 +1870,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (SCHEME_INTP(val)) {
> Tsint32 tmp;
> - tmp = (Tsint32)(SCHEME_INT_VAL(val));
> + tmp = MZ_TYPE_CAST(Tsint32, SCHEME_INT_VAL(val));
> (((Tsint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
> } else {
> wrong_value(who, "_fixint", val);;
> @@ -1873,7 +1885,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (SCHEME_INTP(val)) {
> Tuint32 tmp;
> - tmp = (Tuint32)(SCHEME_UINT_VAL(val));
> + tmp = MZ_TYPE_CAST(Tuint32, SCHEME_UINT_VAL(val));
> (((Tuint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
> } else {
> wrong_value(who, "_ufixint", val);;
> @@ -1888,7 +1900,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (SCHEME_INTP(val)) {
> intptr_t tmp;
> - tmp = (intptr_t)(SCHEME_INT_VAL(val));
> + tmp = MZ_TYPE_CAST(intptr_t, SCHEME_INT_VAL(val));
> (((intptr_t*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
> } else {
> wrong_value(who, "_fixnum", val);;
> @@ -1903,7 +1915,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (SCHEME_INTP(val)) {
> uintptr_t tmp;
> - tmp = (uintptr_t)(SCHEME_UINT_VAL(val));
> + tmp = MZ_TYPE_CAST(uintptr_t, SCHEME_UINT_VAL(val));
> (((uintptr_t*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
> } else {
> wrong_value(who, "_ufixnum", val);;
> @@ -1918,7 +1930,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (SCHEME_FLOATP(val)) {
> float tmp;
> - tmp = (float)(SCHEME_FLOAT_VAL(val));
> + tmp = MZ_TYPE_CAST(float, SCHEME_FLOAT_VAL(val));
> (((float*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
> } else {
> wrong_value(who, "_float", val);;
> @@ -1933,7 +1945,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (SCHEME_FLOATP(val)) {
> double tmp;
> - tmp = (double)(SCHEME_FLOAT_VAL(val));
> + tmp = MZ_TYPE_CAST(double, SCHEME_FLOAT_VAL(val));
> (((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
> } else {
> wrong_value(who, "_double", val);;
> @@ -1948,7 +1960,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (SCHEME_LONG_DBLP(val)) {
> mz_long_double tmp;
> - tmp = (mz_long_double)(SCHEME_MAYBE_LONG_DBL_VAL(val));
> + tmp = MZ_NO_TYPE_CAST(mz_long_double, SCHEME_MAYBE_LONG_DBL_VAL(val));
> (((mz_long_double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
> } else {
> wrong_value(who, "_longdouble", val);;
> @@ -1963,7 +1975,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (SCHEME_REALP(val)) {
> double tmp;
> - tmp = (double)(scheme_real_to_double(val));
> + tmp = MZ_TYPE_CAST(double, scheme_real_to_double(val));
> (((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
> } else {
> wrong_value(who, "_double*", val);;
> @@ -1978,7 +1990,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (1) {
> int tmp;
> - tmp = (int)(SCHEME_TRUEP(val));
> + tmp = MZ_TYPE_CAST(int, SCHEME_TRUEP(val));
> (((int*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
> } else {
> wrong_value(who, "_bool", val);;
> @@ -1993,7 +2005,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
> mzchar* tmp;
> - tmp = (mzchar*)(ucs4_string_or_null_to_ucs4_pointer(val));
> + tmp = MZ_TYPE_CAST(mzchar*, ucs4_string_or_null_to_ucs4_pointer(val));
> if (basetype_p == NULL || tmp == NULL || 0) {
> (((mzchar**)W_OFFSET(dst,delta))[0]) = tmp;
> return NULL;
> @@ -2014,7 +2026,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
> unsigned short* tmp;
> - tmp = (unsigned short*)(ucs4_string_or_null_to_utf16_pointer(val));
> + tmp = MZ_TYPE_CAST(unsigned short*, ucs4_string_or_null_to_utf16_pointer(val));
> if (basetype_p == NULL || tmp == NULL || 0) {
> (((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp;
> return NULL;
> @@ -2035,7 +2047,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (SCHEME_FALSEP(val)||SCHEME_BYTE_STRINGP(val)) {
> char* tmp;
> - tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_BYTE_STR_VAL(val));
> + tmp = MZ_TYPE_CAST(char*, SCHEME_FALSEP(val)?NULL:SCHEME_BYTE_STR_VAL(val));
> if (basetype_p == NULL || tmp == NULL || 0) {
> (((char**)W_OFFSET(dst,delta))[0]) = tmp;
> return NULL;
> @@ -2056,7 +2068,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (SCHEME_FALSEP(val)||SCHEME_PATH_STRINGP(val)) {
> char* tmp;
> - tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_PATH_VAL(TO_PATH(val)));
> + tmp = MZ_TYPE_CAST(char*, SCHEME_FALSEP(val)?NULL:SCHEME_PATH_VAL(TO_PATH(val)));
> if (basetype_p == NULL || tmp == NULL || 0) {
> (((char**)W_OFFSET(dst,delta))[0]) = tmp;
> return NULL;
> @@ -2077,7 +2089,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (SCHEME_SYMBOLP(val)) {
> char* tmp;
> - tmp = (char*)(SCHEME_SYM_VAL(val));
> + tmp = MZ_TYPE_CAST(char*, SCHEME_SYM_VAL(val));
> if (basetype_p == NULL || tmp == NULL || !is_gcable_pointer(val)) {
> (((char**)W_OFFSET(dst,delta))[0]) = tmp;
> return NULL;
> @@ -2098,7 +2110,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (SCHEME_FFIANYPTRP(val)) {
> void* tmp; intptr_t toff;
> - tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
> + tmp = MZ_TYPE_CAST(void*, SCHEME_FFIANYPTR_VAL(val));
> toff = SCHEME_FFIANYPTR_OFFSET(val);
> if (basetype_p == NULL || (tmp == NULL && toff == 0) || !is_gcable_pointer(val)) {
> if (_offset) *_offset = 0;
> @@ -2123,7 +2135,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (SCHEME_FFIANYPTRP(val)) {
> void* tmp; intptr_t toff;
> - tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
> + tmp = MZ_TYPE_CAST(void*, SCHEME_FFIANYPTR_VAL(val));
> toff = SCHEME_FFIANYPTR_OFFSET(val);
> if (basetype_p == NULL || (tmp == NULL && toff == 0) || 0) {
> if (_offset) *_offset = 0;
> @@ -2148,7 +2160,7 @@ static void* SCHEME2C(const char *who,
> # endif /* SCHEME_BIG_ENDIAN */
> if (1) {
> Scheme_Object* tmp;
> - tmp = (Scheme_Object*)(val);
> + tmp = MZ_TYPE_CAST(Scheme_Object*, val);
> if (basetype_p == NULL || tmp == NULL || 0) {
> (((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp;
> return NULL;
>
> src/foreign/foreign.rktc
> ~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/foreign/foreign.rktc
> +++ NEW/src/foreign/foreign.rktc
> @@ -516,6 +516,9 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
> /*****************************************************************************/
> /* Types */
>
> + at DEFINE{MZ_TYPE_CAST(t, e) (t)(e)}
> + at 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)
> + , at 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 || @;
>
> src/get-libs.rkt
> ~~~~~~~~~~~~~~~~
> --- OLD/src/get-libs.rkt
> +++ NEW/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
>
> src/racket/include/scheme.h
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/include/scheme.h
> +++ NEW/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
>
>
> src/racket/include/schthread.h
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/include/schthread.h
> +++ NEW/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_;
>
> src/racket/main.c
> ~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/main.c
> +++ NEW/src/racket/main.c
> @@ -1,3 +1,4 @@
> +
> /*
> Racket
> Copyright (c) 2004-2013 PLT Design Inc.
>
> src/racket/sconfig.h
> ~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/sconfig.h
> +++ NEW/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
>
> src/racket/src/Makefile.in
> ~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/Makefile.in
> +++ NEW/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 \
>
> src/racket/src/bgnfloat.inc
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/bgnfloat.inc
> +++ NEW/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
>
> src/racket/src/bignum.c
> ~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/bignum.c
> +++ NEW/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"
>
> src/racket/src/bool.c
> ~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/bool.c
> +++ NEW/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;
> }
>
> src/racket/src/env.c
> ~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/env.c
> +++ NEW/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();
>
> src/racket/src/file.c
> ~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/file.c
> +++ NEW/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) {
>
> src/racket/src/hash.c
> ~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/hash.c
> +++ NEW/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)
>
> src/racket/src/jit.c
> ~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/jit.c
> +++ NEW/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);
>
> src/racket/src/jit.h
> ~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/jit.h
> +++ NEW/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);
>
> src/racket/src/jitalloc.c
> ~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/jitalloc.c
> +++ NEW/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)
> {
>
> src/racket/src/jitarith.c
> ~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/jitarith.c
> +++ NEW/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
>
> src/racket/src/jitinline.c
> ~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/jitinline.c
> +++ NEW/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,
>
> src/racket/src/jitstate.c
> ~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/jitstate.c
> +++ NEW/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++;
>
> src/racket/src/lightning/i386/asm.h
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/lightning/i386/asm.h
> +++ NEW/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)) : \
>
> src/racket/src/lightning/i386/fp-extfpu.h
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/lightning/i386/fp-extfpu.h
> +++ NEW/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
>
> src/racket/src/longdouble/longdouble.c
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/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 <stdint.h>
> +#include "longdouble.h"
> +#include <math.h>
> +#include <stdio.h>
> +#include <string.h>
> +
> +LDBL_DLL_API void set_x87_control(int v)
> +{
> + asm ("fldcw %0" : : "m" (v));
> +}
> +
> +LDBL_DLL_API int get_x87_control()
> +{
> + int v;
> + asm ("fnstcw %0" : : "m" (v));
> + return v;
> +}
> +
> +static void ext_mode()
> +{
> + set_x87_control(0x37F);
> +}
> +
> +static void default_mode()
> +{
> + set_x87_control(0x27F);
> +}
> +
> +long_double get_long_double_infinity_val()
> +{
> + long_double result;
> + ext_mode();
> + result.val = 1.0L / get_long_double_zero().val;
> + default_mode();
> + return result;
> +}
> +
> +long_double get_long_double_minus_infinity_val()
> +{
> + long_double result;
> + ext_mode();
> + result.val = -get_long_double_infinity_val().val;
> + default_mode();
> + return result;
> +}
> +
> +long_double get_long_double_zero()
> +{
> + long_double result;
> + ext_mode();
> + result.val = 0.0L;
> + default_mode();
> + return result;
> +}
> +
> +long_double get_long_double_nzero()
> +{
> + long_double result;
> + ext_mode();
> + result.val = -1.0L / get_long_double_infinity_val().val;
> + default_mode();
> + return result;
> +}
> +
> +long_double get_long_double_nan()
> +{
> + long_double result;
> + ext_mode();
> + result.val = get_long_double_infinity_val().val + get_long_double_minus_infinity_val().val;
> + default_mode();
> + return result;
> +}
> +
> +long_double get_long_double_1()
> +{
> + long_double result;
> + ext_mode();
> + result.val = 1.0L;
> + default_mode();
> + return result;
> +}
> +long_double get_long_double_minus_1()
> +{
> + long_double result;
> + ext_mode();
> + result.val = -1.0L;
> + default_mode();
> + return result;
> +}
> +long_double get_long_double_2()
> +{
> + long_double result;
> + ext_mode();
> + result.val = 2.0L;
> + default_mode();
> + return result;
> +}
> +
> +long_double get_long_double_one_half()
> +{
> + long_double result;
> + ext_mode();
> + result.val = 0.5L;
> + default_mode();
> + return result;
> +}
> +
> +long_double get_long_double_pi()
> +{
> + long_double result;
> + ext_mode();
> + result.val = atan2l(0.0L, -1.0L);
> + default_mode();
> + return result;
> +}
> +
> +long_double get_long_double_half_pi()
> +{
> + long_double result;
> + ext_mode();
> + result.val = atan2l(0.0L, -1.0L)/2.0L;
> + default_mode();
> + return result;
> +}
> +long_double long_double_from_int(int a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = (long double) a;
> + default_mode();
> + return result;
> +}
> +
> +
> +long_double long_double_from_float(float a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = (long double) a;
> + default_mode();
> + return result;
> +}
> +
> +long_double long_double_from_double(double a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = (long double) a;
> + default_mode();
> + return result;
> +}
> +
> +long_double long_double_from_uintptr(uintptr_t a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = a;
> + default_mode();
> + return result;
> +}
> +
> +double double_from_long_double(long_double a)
> +{
> + return (double)a.val;
> +}
> +
> +float float_from_long_double(long_double a)
> +{
> + return (float)a.val;
> +}
> +intptr_t int_from_long_double(long_double a)
> +{
> + return (intptr_t)a.val;
> +}
> +
> +long_double long_double_plus(long_double a, long_double b)
> +{
> + long_double result;
> + ext_mode();
> + result.val = a.val + b.val;
> + default_mode();
> + return result;
> +}
> +
> +long_double long_double_minus(long_double a, long_double b)
> +{
> + long_double result;
> + ext_mode();
> + result.val = a.val - b.val;
> + default_mode();
> + return result;
> +}
> +
> +long_double long_double_mult(long_double a, long_double b)
> +{
> + long_double result;
> + ext_mode();
> + result.val = a.val * b.val;
> + default_mode();
> + return result;
> +}
> +
> +long_double long_double_mult_i(long_double a, int b)
> +{
> + long_double result;
> + ext_mode();
> + result.val = a.val * b;
> + default_mode();
> + return result;
> +}
> +
> +uintptr_t uintptr_from_long_double(long_double a)
> +{
> + uintptr_t result;
> + ext_mode();
> + result = a.val;
> + default_mode();
> + return result;
> +}
> +
> +long_double long_double_div(long_double a, long_double b)
> +{
> + long_double result;
> + ext_mode();
> + result.val = a.val / b.val;
> + default_mode();
> + return result;
> +}
> +long_double long_double_neg(long_double a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = -a.val;
> + default_mode();
> + return result;
> +}
> +
> +int long_double_eqv(long_double a, long_double b)
> +{
> + return a.val == b.val;
> +}
> +int long_double_less(long_double a, long_double b)
> +{
> + return a.val < b.val;
> +}
> +int long_double_less_or_eqv(long_double a, long_double b)
> +{
> + return a.val <= b.val;
> +}
> +int long_double_greater(long_double a, long_double b)
> +{
> + return a.val > b.val;
> +}
> +int long_double_greater_or_eqv(long_double a, long_double b)
> +{
> + return a.val >= b.val;
> +}
> +
> +int long_double_eqv_i(int a, long_double b)
> +{
> + return (long double) a == b.val;
> +}
> +
> +int long_double_is_zero(long_double a)
> +{
> + return a.val == 0.0L;
> +}
> +
> +int long_double_is_1(long_double a)
> +{
> + return a.val == 1.0L;
> +}
> +
> +int long_double_minus_zero_p(long_double a)
> +{
> + int v;
> + ext_mode();
> + v = ((1.0L / a.val) < 0.0L);
> + default_mode();
> + return v;
> +}
> +int long_double_is_nan(long_double a)
> +{
> + return isnan(a.val);
> +}
> +int long_double_is_pos_infinity(long_double a)
> +{
> + return isinf(a.val) && a.val > 0;
> +}
> +
> +int long_double_is_neg_infinity(long_double a)
> +{
> + return isinf(a.val) && a.val < 0;
> +}
> +
> +int long_double_is_infinity(long_double a)
> +{
> + return isinf(a.val);
> +}
> +
> +long_double long_double_fabs(long_double a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = fabsl(a.val);
> + default_mode();
> + return result;
> +}
> +
> +long_double long_double_modf(long_double a, long_double *b)
> +{
> + long_double result;
> + ext_mode();
> + result.val = modfl(a.val, &b->val);
> + default_mode();
> + return result;
> +}
> +long_double long_double_fmod(long_double a, long_double b)
> +{
> + long_double result;
> + ext_mode();
> + result.val = fmodl(a.val, b.val);
> + default_mode();
> + return result;
> +}
> +long_double long_double_trunc(long_double a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = truncl(a.val);
> + default_mode();
> + return result;
> +
> +}
> +long_double long_double_floor(long_double a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = floorl(a.val);
> + default_mode();
> + return result;
> +}
> +long_double long_double_ceil(long_double a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = ceill(a.val);
> + default_mode();
> + return result;
> +}
> +
> +long_double long_double_sin(long_double a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = sinl(a.val);
> + default_mode();
> + return result;
> +}
> +long_double long_double_cos(long_double a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = cosl(a.val);
> + default_mode();
> + return result;
> +}
> +long_double long_double_tan(long_double a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = tanl(a.val);
> + default_mode();
> + return result;
> +}
> +long_double long_double_asin(long_double a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = asinl(a.val);
> + default_mode();
> + return result;
> +}
> +long_double long_double_acos(long_double a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = acosl(a.val);
> + default_mode();
> + return result;
> +}
> +long_double long_double_atan(long_double a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = atanl(a.val);
> + default_mode();
> + return result;
> +}
> +long_double long_double_log(long_double a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = logl(a.val);
> + default_mode();
> + return result;
> +}
> +long_double long_double_exp(long_double a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = expl(a.val);
> + default_mode();
> + return result;
> +}
> +
> +long_double long_double_ldexp(long_double a, int i)
> +{
> + long_double result;
> + ext_mode();
> + result.val = ldexpl(a.val, i);
> + default_mode();
> + return result;
> +}
> +
> +long_double long_double_pow(long_double a, long_double b)
> +{
> + long_double result;
> + ext_mode();
> + result.val = powl(a.val, b.val);
> + default_mode();
> + return result;
> +}
> +
> +long_double long_double_sqrt(long_double a)
> +{
> + long_double result;
> + ext_mode();
> + result.val = sqrtl(a.val);
> + default_mode();
> + return result;
> +}
> +
> +long_double long_double_frexp(long_double a, int* i)
> +{
> + long_double result;
> + ext_mode();
> + result.val = frexpl(a.val, i);
> + default_mode();
> + return result;
> +}
> +
> +void long_double_sprint(char* buffer, int digits, long_double d)
> +{
> + ext_mode();
> + __mingw_sprintf(buffer, "%.*Lg", digits, d.val);
> + default_mode();
> +}
> +
> +long_double long_double_array_ref(void *pointer, int index)
> +{
> + long_double result;
> + result = ((long_double *)pointer)[index];
> + return result;
> +}
> +
> +void long_double_array_set(void *pointer, int index, long_double value)
> +{
> + ((long_double *)pointer)[index] = value;
> + return ;
> +}
> +
> +long_double long_double_from_string(char* buff, char** p)
> +{
> + long_double result;
> + char* ptr, one_char;
> + int n;
> + ext_mode();
> + n = __mingw_sscanf(buff, "%Lf%c", &result.val, &one_char);
> + default_mode();
> + if (n == 1) {
> + /* all characters consumed for the number */
> + *p = &buff[strlen(buff)];
> + } else {
> + /* didn't use the input string exactly;
> + pretend that no characters were consumed */
> + *p = buff;
> + }
> + return result;
> +}
> +
> +#else
> +
> +/* Glue code */
> +
> +#ifdef MZ_PRECISE_GC
> +START_XFORM_SKIP;
> +#endif
> +
> +static int long_double_dll_available;
> +
> +/* pointers to dynamically loaded functions */
> +#define DECLARE_LDBL(res, name, args) \
> + typedef res (* name ## _t)args; \
> + static name ## _t _imp_ ## name;
> +DECLARE_LDBL(long_double, get_long_double_infinity_val, ())
> +DECLARE_LDBL(long_double, get_long_double_minus_infinity_val, ())
> +DECLARE_LDBL(long_double, get_long_double_zero, ())
> +DECLARE_LDBL(long_double, get_long_double_nzero, ())
> +DECLARE_LDBL(long_double, get_long_double_nan, ())
> +DECLARE_LDBL(long_double, get_long_double_1, ())
> +DECLARE_LDBL(long_double, get_long_double_minus_1, ())
> +DECLARE_LDBL(long_double, get_long_double_2, ())
> +DECLARE_LDBL(long_double, get_long_double_one_half, ())
> +DECLARE_LDBL(long_double, get_long_double_pi, ())
> +DECLARE_LDBL(long_double, get_long_double_half_pi, ())
> +DECLARE_LDBL(void, set_long_double, (long_double a, long_double b))
> +DECLARE_LDBL(long_double, long_double_from_int, (int a))
> +DECLARE_LDBL(long_double, long_double_from_float, (float a))
> +DECLARE_LDBL(long_double, long_double_from_double, (double a))
> +DECLARE_LDBL(long_double, long_double_from_uintptr, (uintptr_t a))
> +DECLARE_LDBL(double, double_from_long_double, (long_double a))
> +DECLARE_LDBL(float, float_from_long_double, (long_double a))
> +DECLARE_LDBL(intptr_t, int_from_long_double, (long_double a))
> +DECLARE_LDBL(uintptr_t, uintptr_from_long_double, (long_double a))
> +DECLARE_LDBL(long_double, long_double_plus, (long_double a, long_double b))
> +DECLARE_LDBL(long_double, long_double_minus, (long_double a, long_double b))
> +DECLARE_LDBL(long_double, long_double_mult, (long_double a, long_double b))
> +DECLARE_LDBL(long_double, long_double_mult_i, (long_double a, int b))
> +DECLARE_LDBL(long_double, long_double_div, (long_double a, long_double b))
> +DECLARE_LDBL(long_double, long_double_neg, (long_double a))
> +DECLARE_LDBL(int, long_double_eqv, (long_double a, long_double b))
> +DECLARE_LDBL(int, long_double_less, (long_double a, long_double b))
> +DECLARE_LDBL(int, long_double_less_or_eqv, (long_double a, long_double b))
> +DECLARE_LDBL(int, long_double_greater, (long_double a, long_double b))
> +DECLARE_LDBL(int, long_double_greater_or_eqv, (long_double a, long_double b))
> +DECLARE_LDBL(int, long_double_eqv_i, (int a, long_double b))
> +DECLARE_LDBL(int, long_double_is_zero, (long_double a))
> +DECLARE_LDBL(int, long_double_is_1, (long_double a))
> +DECLARE_LDBL(int, long_double_minus_zero_p, (long_double a))
> +DECLARE_LDBL(int, long_double_is_nan, (long_double a))
> +DECLARE_LDBL(int, long_double_is_pos_infinity, (long_double a))
> +DECLARE_LDBL(int, long_double_is_neg_infinity, (long_double a))
> +DECLARE_LDBL(int, long_double_is_infinity, (long_double a))
> +DECLARE_LDBL(long_double, long_double_fabs, (long_double a))
> +DECLARE_LDBL(long_double, long_double_modf, (long_double a, long_double *b))
> +DECLARE_LDBL(long_double, long_double_fmod, (long_double a, long_double b))
> +DECLARE_LDBL(long_double, long_double_trunc, (long_double a))
> +DECLARE_LDBL(long_double, long_double_floor, (long_double a))
> +DECLARE_LDBL(long_double, long_double_ceil, (long_double a))
> +DECLARE_LDBL(long_double, long_double_sin, (long_double a))
> +DECLARE_LDBL(long_double, long_double_cos, (long_double a))
> +DECLARE_LDBL(long_double, long_double_tan, (long_double a))
> +DECLARE_LDBL(long_double, long_double_asin, (long_double a))
> +DECLARE_LDBL(long_double, long_double_acos, (long_double a))
> +DECLARE_LDBL(long_double, long_double_atan, (long_double a))
> +DECLARE_LDBL(long_double, long_double_log, (long_double a))
> +DECLARE_LDBL(long_double, long_double_exp, (long_double a))
> +DECLARE_LDBL(long_double, long_double_ldexp, (long_double a, int i))
> +DECLARE_LDBL(long_double, long_double_pow, (long_double a, long_double b))
> +DECLARE_LDBL(long_double, long_double_sqrt, (long_double a))
> +DECLARE_LDBL(long_double, long_double_frexp, (long_double a, int* i))
> +DECLARE_LDBL(void, long_double_sprint, (char* buffer, int digits, long_double d))
> +DECLARE_LDBL(long_double, long_double_array_ref, (void *pointer, int index))
> +DECLARE_LDBL(void, long_double_array_set, (void *pointer, int index, long_double value))
> +DECLARE_LDBL(long_double, long_double_from_string, (char* buff, char** p))
> +DECLARE_LDBL(void, set_x87_control, (int v))
> +DECLARE_LDBL(int, get_x87_control, ())
> +
> +static long_double fail_long_double() {
> + long_double d;
> + memset(&d, 0, sizeof(d));
> + return d;
> +}
> +
> +static int fail_int() { return 0; }
> +static void fail_void() { }
> +static double fail_double() { return 0.0; }
> +static float fail_float() { return 0.0; }
> +static uintptr_t fail_uintptr() { return 0; }
> +
> +/* If "longdouble.dll" is not available, then fall back to `double'
> + parsing and printing, so that we can at least implement reading
> + and printing (which are supposed to always work). */
> +
> +static long_double fail_from_string(char* buff, char** p)
> +{
> + double d;
> + long_double ld;
> +
> + d = strtod(buff, p, 0);
> + memcpy(&ld, &d, sizeof(double));
> +
> + return ld;
> +}
> +
> +static void fail_sprint(char* buffer, int digits, long_double ld)
> +{
> + double d;
> + memcpy(&d, &ld, sizeof(double));
> + sprintf(buffer, "%.*Lg", digits, d);
> +}
> +
> +/* initialization */
> +void scheme_load_long_double_dll()
> +{
> + HANDLE m;
> + m = LoadLibraryW(scheme_get_dll_path(L"longdouble.dll"));
> +
> + if (m) long_double_dll_available = 1;
> +
> +# define EXTRACT_LDBL(name, fail) \
> + _imp_ ## name = (name ##_t)(m ? GetProcAddress(m, # name) : NULL); \
> + if (!(_imp_ ## name)) _imp_ ## name = (name ##_t)fail;
> +
> + EXTRACT_LDBL(get_long_double_infinity_val, fail_long_double);
> + EXTRACT_LDBL(get_long_double_minus_infinity_val, fail_long_double);
> + EXTRACT_LDBL(get_long_double_zero, fail_long_double);
> + EXTRACT_LDBL(get_long_double_nzero, fail_long_double);
> + EXTRACT_LDBL(get_long_double_nan, fail_long_double);
> + EXTRACT_LDBL(get_long_double_1, fail_long_double);
> + EXTRACT_LDBL(get_long_double_minus_1, fail_long_double);
> + EXTRACT_LDBL(get_long_double_2, fail_long_double);
> + EXTRACT_LDBL(get_long_double_one_half, fail_long_double);
> + EXTRACT_LDBL(get_long_double_pi, fail_long_double);
> + EXTRACT_LDBL(get_long_double_half_pi, fail_long_double);
> + EXTRACT_LDBL(set_long_double, fail_void);
> + EXTRACT_LDBL(long_double_from_int, fail_long_double);
> + EXTRACT_LDBL(long_double_from_float, fail_long_double);
> + EXTRACT_LDBL(long_double_from_double, fail_long_double);
> + EXTRACT_LDBL(long_double_from_uintptr, fail_long_double);
> + EXTRACT_LDBL(double_from_long_double, fail_double);
> + EXTRACT_LDBL(float_from_long_double, fail_float);
> + EXTRACT_LDBL(int_from_long_double, fail_int);
> + EXTRACT_LDBL(uintptr_from_long_double, fail_uintptr);
> + EXTRACT_LDBL(long_double_plus, fail_long_double);
> + EXTRACT_LDBL(long_double_minus, fail_long_double);
> + EXTRACT_LDBL(long_double_mult, fail_long_double);
> + EXTRACT_LDBL(long_double_mult_i, fail_long_double);
> + EXTRACT_LDBL(long_double_div, fail_long_double);
> + EXTRACT_LDBL(long_double_neg, fail_long_double);
> + EXTRACT_LDBL(long_double_eqv, fail_int);
> + EXTRACT_LDBL(long_double_less, fail_int);
> + EXTRACT_LDBL(long_double_less_or_eqv, fail_int);
> + EXTRACT_LDBL(long_double_greater, fail_int);
> + EXTRACT_LDBL(long_double_greater_or_eqv, fail_int);
> + EXTRACT_LDBL(long_double_eqv_i, fail_int);
> + EXTRACT_LDBL(long_double_is_zero, fail_int);
> + EXTRACT_LDBL(long_double_is_1, fail_int);
> + EXTRACT_LDBL(long_double_minus_zero_p, fail_int);
> + EXTRACT_LDBL(long_double_is_nan, fail_int);
> + EXTRACT_LDBL(long_double_is_pos_infinity, fail_int);
> + EXTRACT_LDBL(long_double_is_neg_infinity, fail_int);
> + EXTRACT_LDBL(long_double_is_infinity, fail_int);
> + EXTRACT_LDBL(long_double_fabs, fail_long_double);
> + EXTRACT_LDBL(long_double_modf, fail_long_double);
> + EXTRACT_LDBL(long_double_fmod, fail_long_double);
> + EXTRACT_LDBL(long_double_trunc, fail_long_double);
> + EXTRACT_LDBL(long_double_floor, fail_long_double);
> + EXTRACT_LDBL(long_double_ceil, fail_long_double);
> + EXTRACT_LDBL(long_double_sin, fail_long_double);
> + EXTRACT_LDBL(long_double_cos, fail_long_double);
> + EXTRACT_LDBL(long_double_tan, fail_long_double);
> + EXTRACT_LDBL(long_double_asin, fail_long_double);
> + EXTRACT_LDBL(long_double_acos, fail_long_double);
> + EXTRACT_LDBL(long_double_atan, fail_long_double);
> + EXTRACT_LDBL(long_double_log, fail_long_double);
> + EXTRACT_LDBL(long_double_exp, fail_long_double);
> + EXTRACT_LDBL(long_double_ldexp, fail_long_double);
> + EXTRACT_LDBL(long_double_pow, fail_long_double);
> + EXTRACT_LDBL(long_double_sqrt, fail_long_double);
> + EXTRACT_LDBL(long_double_frexp, fail_long_double);
> + EXTRACT_LDBL(long_double_sprint, fail_sprint);
> + EXTRACT_LDBL(long_double_array_ref, fail_long_double);
> + EXTRACT_LDBL(long_double_array_set, fail_void);
> + EXTRACT_LDBL(long_double_from_string, fail_from_string);
> + EXTRACT_LDBL(set_x87_control, fail_void);
> + EXTRACT_LDBL(get_x87_control, fail_int);
> +}
> +
> +int long_double_available() {
> + return long_double_dll_available;
> +}
> +
> +/* Glue functions */
> +
> +long_double get_long_double_infinity_val() { return _imp_get_long_double_infinity_val(); }
> +long_double get_long_double_minus_infinity_val() { return _imp_get_long_double_minus_infinity_val(); }
> +long_double get_long_double_zero() { return _imp_get_long_double_zero(); }
> +long_double get_long_double_nzero() { return _imp_get_long_double_nzero(); }
> +long_double get_long_double_nan() { return _imp_get_long_double_nan(); }
> +long_double get_long_double_1() { return _imp_get_long_double_1(); }
> +long_double get_long_double_minus_1() { return _imp_get_long_double_minus_1(); }
> +long_double get_long_double_2() { return _imp_get_long_double_2(); }
> +long_double get_long_double_one_half() { return _imp_get_long_double_one_half(); }
> +long_double get_long_double_pi() { return _imp_get_long_double_pi(); }
> +long_double get_long_double_half_pi() { return _imp_get_long_double_half_pi(); }
> +
> +void set_long_double(long_double a, long_double b) { _imp_set_long_double(a, b); }
> +
> +long_double long_double_from_int(int a) { return _imp_long_double_from_int(a); }
> +long_double long_double_from_float(float a) { return _imp_long_double_from_float(a); }
> +long_double long_double_from_double(double a) { return _imp_long_double_from_double(a); }
> +long_double long_double_from_uintptr(uintptr_t a) { return _imp_long_double_from_uintptr(a); }
> +
> +double double_from_long_double(long_double a) { return _imp_double_from_long_double(a); }
> +float float_from_long_double(long_double a) { return _imp_float_from_long_double(a); }
> +intptr_t int_from_long_double(long_double a) { return _imp_int_from_long_double(a); }
> +
> +uintptr_t uintptr_from_long_double(long_double a) { return _imp_uintptr_from_long_double(a); }
> +
> +long_double long_double_plus(long_double a, long_double b) { return _imp_long_double_plus(a, b); }
> +long_double long_double_minus(long_double a, long_double b) { return _imp_long_double_minus(a, b); }
> +long_double long_double_mult(long_double a, long_double b) { return _imp_long_double_mult(a, b); }
> +long_double long_double_mult_i(long_double a, int b) { return _imp_long_double_mult_i(a, b); }
> +long_double long_double_div(long_double a, long_double b) { return _imp_long_double_div(a, b); }
> +long_double long_double_neg(long_double a) { return _imp_long_double_neg(a); }
> +
> +int long_double_eqv(long_double a, long_double b) { return _imp_long_double_eqv(a, b); }
> +int long_double_less(long_double a, long_double b) { return _imp_long_double_less(a, b); }
> +int long_double_less_or_eqv(long_double a, long_double b) { return _imp_long_double_less_or_eqv(a, b); }
> +int long_double_greater(long_double a, long_double b) { return _imp_long_double_greater(a, b); }
> +int long_double_greater_or_eqv(long_double a, long_double b) { return _imp_long_double_greater_or_eqv(a, b); }
> +
> +int long_double_eqv_i(int a, long_double b) { return _imp_long_double_eqv_i(a, b); }
> +
> +int long_double_is_zero(long_double a) { return _imp_long_double_is_zero(a); }
> +int long_double_is_1(long_double a) { return _imp_long_double_is_1(a); }
> +int long_double_minus_zero_p(long_double a) { return _imp_long_double_minus_zero_p(a); }
> +int long_double_is_nan(long_double a) { return _imp_long_double_is_nan(a); }
> +int long_double_is_pos_infinity(long_double a) { return _imp_long_double_is_pos_infinity(a); }
> +int long_double_is_neg_infinity(long_double a) { return _imp_long_double_is_neg_infinity(a); }
> +int long_double_is_infinity(long_double a) { return _imp_long_double_is_infinity(a); }
> +
> +long_double long_double_fabs(long_double a) { return _imp_long_double_fabs(a); }
> +long_double long_double_modf(long_double a, long_double *b) { return _imp_long_double_modf(a, b); }
> +long_double long_double_fmod(long_double a, long_double b) { return _imp_long_double_fmod(a, b); }
> +long_double long_double_trunc(long_double a) { return _imp_long_double_trunc(a); }
> +long_double long_double_floor(long_double a) { return _imp_long_double_floor(a); }
> +long_double long_double_ceil(long_double a) { return _imp_long_double_ceil(a); }
> +
> +long_double long_double_sin(long_double a) { return _imp_long_double_sin(a); }
> +long_double long_double_cos(long_double a) { return _imp_long_double_cos(a); }
> +long_double long_double_tan(long_double a) { return _imp_long_double_tan(a); }
> +long_double long_double_asin(long_double a) { return _imp_long_double_asin(a); }
> +long_double long_double_acos(long_double a) { return _imp_long_double_acos(a); }
> +long_double long_double_atan(long_double a) { return _imp_long_double_atan(a); }
> +long_double long_double_log(long_double a) { return _imp_long_double_log(a); }
> +long_double long_double_exp(long_double a) { return _imp_long_double_exp(a); }
> +long_double long_double_ldexp(long_double a, int i) { return _imp_long_double_ldexp(a, i); }
> +
> +long_double long_double_pow(long_double a, long_double b) { return _imp_long_double_pow(a, b); }
> +
> +long_double long_double_sqrt(long_double a) { return _imp_long_double_sqrt(a); }
> +
> +long_double long_double_frexp(long_double a, int* i) { return _imp_long_double_frexp(a, i); }
> +
> +void long_double_sprint(char* buffer, int digits, long_double d) { _imp_long_double_sprint(buffer, digits, d); }
> +
> +long_double long_double_array_ref(void *pointer, int index) { return _imp_long_double_array_ref(pointer, index); }
> +void long_double_array_set(void *pointer, int index, long_double value) { _imp_long_double_array_set(pointer, index, value); }
> +
> +long_double long_double_from_string(char* buff, char** p) { return _imp_long_double_from_string(buff, p); }
> +
> +void to_double_prec() { _imp_set_x87_control(0x27F); }
> +void to_extended_prec() { _imp_set_x87_control(0x37F); }
> +
> +#ifdef MZ_PRECISE_GC
> +END_XFORM_SKIP;
> +#endif
> +
> +#endif
>
> src/racket/src/longdouble/longdouble.h
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/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
>
> src/racket/src/numarith.c
> ~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/numarith.c
> +++ NEW/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)
>
> src/racket/src/number.c
> ~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/number.c
> +++ NEW/src/racket/src/number.c
> @@ -25,6 +25,7 @@
>
> #include "schpriv.h"
> #include "nummacs.h"
> +#include "longdouble/longdouble.h"
> #include <math.h>
> #include <string.h>
> #include <ctype.h>
> @@ -234,12 +235,12 @@ READ_ONLY Scheme_Object *scheme_single_inf_object, *scheme_single_minus_inf_obje
> #endif
>
> #ifdef MZ_LONG_DOUBLE
> -READ_ONLY long double scheme_long_infinity_val;
> -READ_ONLY long double scheme_long_minus_infinity_val;
> -READ_ONLY long double scheme_long_floating_point_zero = 0.0L;
> -READ_ONLY long double scheme_long_floating_point_nzero = 0.0L; /* negated below; many compilers treat -0.0 as 0.0,
> +READ_ONLY long_double scheme_long_infinity_val;
> +READ_ONLY long_double scheme_long_minus_infinity_val;
> +READ_ONLY long_double scheme_long_floating_point_zero;
> +READ_ONLY long_double scheme_long_floating_point_nzero; /* negated below; many compilers treat -0.0 as 0.0,
> but otherwise correctly implement fp negation */
> -READ_ONLY static long double long_not_a_number_val;
> +READ_ONLY static long_double long_not_a_number_val;
>
> READ_ONLY Scheme_Object *scheme_long_inf_object, *scheme_long_minus_inf_object, *scheme_long_nan_object;
>
> @@ -271,8 +272,8 @@ static void to_double_prec(void)
> #if defined(ASM_DBLPREC_CONTROL_87) || defined(ASM_EXTPREC_CONTROL_87)
> static void to_extended_prec(void)
> {
> - int _dblprec = 0x37F;
> - asm ("fldcw %0" : : "m" (_dblprec));
> + int _extprec = 0x37F;
> + asm ("fldcw %0" : : "m" (_extprec));
> }
> #endif
>
> @@ -301,6 +302,13 @@ void scheme_configure_floating_point(void)
> should do this, but explicitly masking exceptions
> makes Racket work under Bochs 2.1.1 with Win95 */
> _control87(_MCW_EM, _MCW_EM);
> + /* When MZ_LONG_DOUBLE is defined, it might make sense
> + to try to put the processor in extended-precision
> + mode, but control87() seems to disallow that, and
> + library functions seem to reset the mode, anyway.
> + So, we set and restore the mode as needed in
> + the "longdouble.c"-based DLL and JIT-generated
> + code. */
> #endif
> #ifdef ALPHA_CONTROL_FP
> {
> @@ -410,40 +418,39 @@ scheme_init_number (Scheme_Env *env)
> #endif
>
> #ifdef MZ_LONG_DOUBLE
> + scheme_long_floating_point_zero = get_long_double_zero();
> #if defined(HUGE_VALL) && !defined(USE_DIVIDE_MAKE_INFINITY)
> scheme_long_infinity_val = HUGE_VALL;
> #else
> #ifndef USE_LONG_INFINITY_FUNC
> - scheme_long_infinity_val = 1.0L / scheme_long_floating_point_zero;
> + scheme_long_infinity_val = long_double_div(get_long_double_1(), scheme_long_floating_point_zero);
> #else
> scheme_long_infinity_val = long_infinity();
> #endif
> #endif
>
> #ifdef ZERO_LONG_MINUS_ZERO_IS_LONG_POS_ZERO
> - scheme_long_floating_point_nzero = -1.0L / scheme_long_infinity_val;
> + scheme_long_floating_point_nzero = long_double_div(long_double_neq(long_double_1(), scheme_long_infinity_val));
> #else
> - scheme_long_floating_point_nzero = - scheme_long_floating_point_nzero;
> + scheme_long_floating_point_nzero = long_double_neg(scheme_long_floating_point_nzero);
> #endif
>
> - scheme_long_minus_infinity_val = -scheme_long_infinity_val;
> - long_not_a_number_val = scheme_long_infinity_val + scheme_long_minus_infinity_val;
> + scheme_long_minus_infinity_val = long_double_neg(scheme_long_infinity_val);
> + long_not_a_number_val = long_double_plus(scheme_long_infinity_val, scheme_long_minus_infinity_val);
> + long_not_a_number_val = long_double_sqrt(long_double_neg(get_long_double_1()));
>
> - scheme_zerol = scheme_make_long_double(1.0L);
> - SCHEME_LONG_DBL_VAL(scheme_zerol) = 0.0L;
> - scheme_nzerol = scheme_make_long_double(-1.0L);
> + scheme_zerol = scheme_make_long_double(get_long_double_1());
> + SCHEME_LONG_DBL_VAL(scheme_zerol) = get_long_double_zero();
> + scheme_nzerol = scheme_make_long_double(long_double_neg(get_long_double_1()));
> SCHEME_LONG_DBL_VAL(scheme_nzerol) = scheme_long_floating_point_nzero;
>
> - scheme_long_pi = scheme_make_long_double(atan2l(0.0L, -1.0L));
> - scheme_long_half_pi = scheme_make_long_double(atan2l(0.0L, -1.0L)/2);
> + scheme_long_pi = scheme_make_long_double(get_long_double_pi());
> + scheme_long_half_pi = scheme_make_long_double(get_long_double_half_pi());
>
> - scheme_long_plus_i = scheme_make_complex(scheme_make_integer(0), scheme_make_integer(1));
> - scheme_long_minus_i = scheme_make_complex(scheme_make_integer(0), scheme_make_integer(-1));
> -
> scheme_long_inf_object = scheme_make_long_double(scheme_long_infinity_val);
> scheme_long_minus_inf_object = scheme_make_long_double(scheme_long_minus_infinity_val);
> #ifdef NAN_EQUALS_ANYTHING
> - scheme_long_nan_object = scheme_make_long_double(1L);
> + scheme_long_nan_object = scheme_make_long_double(get_long_double_1());
> SCHEME_LONG_DBL_VAL(scheme_long_nan_object) = long_not_a_number_val;
> #else
> scheme_long_nan_object = scheme_make_long_double(long_not_a_number_val);
> @@ -1055,7 +1062,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extflvector-length", p, env);
>
> p = scheme_make_immed_prim(scheme_checked_extflvector_ref, "extflvector-ref", 2, 2);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_BINARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1064,7 +1071,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extflvector-ref", p, env);
>
> p = scheme_make_immed_prim(scheme_checked_extflvector_set, "extflvector-set!", 3, 3);
> - if (MZ_LONG_DOUBLE_AND(1))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(1))
> flags = SCHEME_PRIM_IS_NARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1073,7 +1080,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extflvector-set!", p, env);
>
> p = scheme_make_folding_prim(integer_to_extfl, "->extfl", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1082,7 +1089,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("->extfl", p, env);
>
> p = scheme_make_folding_prim(extfl_to_integer, "extfl->exact-integer", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1090,7 +1097,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extfl->exact-integer", p, env);
>
> p = scheme_make_folding_prim(real_to_long_double_flonum, "real->extfl", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1099,7 +1106,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("real->extfl", p, env);
>
> p = scheme_make_folding_prim(extfl_to_exact, "extfl->exact", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(1))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(1))
> flags = SCHEME_PRIM_IS_NARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1107,7 +1114,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extfl->exact", p, env);
>
> p = scheme_make_folding_prim(extfl_to_inexact, "extfl->inexact", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(1))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(1))
> flags = SCHEME_PRIM_IS_NARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1115,7 +1122,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extfl->inexact", p, env);
>
> p = scheme_make_folding_prim(fx_to_extfl, "fx->extfl", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1124,7 +1131,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("fx->extfl", p, env);
>
> p = scheme_make_folding_prim(extfl_to_fx, "extfl->fx", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1135,7 +1142,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
>
>
> p = scheme_make_folding_prim(extfl_truncate, "extfltruncate", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1145,7 +1152,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extfltruncate", p, env);
>
> p = scheme_make_folding_prim(extfl_round, "extflround", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1155,7 +1162,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extflround", p, env);
>
> p = scheme_make_folding_prim(extfl_ceiling, "extflceiling", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1165,7 +1172,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extflceiling", p, env);
>
> p = scheme_make_folding_prim(extfl_floor, "extflfloor", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1175,7 +1182,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extflfloor", p, env);
>
> p = scheme_make_folding_prim(extfl_sin, "extflsin", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1185,7 +1192,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extflsin", p, env);
>
> p = scheme_make_folding_prim(extfl_cos, "extflcos", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1195,7 +1202,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extflcos", p, env);
>
> p = scheme_make_folding_prim(extfl_tan, "extfltan", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1205,7 +1212,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extfltan", p, env);
>
> p = scheme_make_folding_prim(extfl_asin, "extflasin", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1215,7 +1222,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extflasin", p, env);
>
> p = scheme_make_folding_prim(extfl_acos, "extflacos", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1225,7 +1232,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extflacos", p, env);
>
> p = scheme_make_folding_prim(extfl_atan, "extflatan", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1235,7 +1242,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extflatan", p, env);
>
> p = scheme_make_folding_prim(extfl_log, "extfllog", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1245,7 +1252,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extfllog", p, env);
>
> p = scheme_make_folding_prim(extfl_exp, "extflexp", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1255,7 +1262,7 @@ void scheme_init_extfl_number(Scheme_Env *env)
> scheme_add_global_constant("extflexp", p, env);
>
> p = scheme_make_folding_prim(extfl_expt, "extflexpt", 2, 2, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_BINARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1438,7 +1445,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env)
> int flags;
>
> p = scheme_make_folding_prim(unsafe_fx_to_extfl, "unsafe-fx->extfl", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1448,7 +1455,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env)
> scheme_add_global_constant("unsafe-fx->extfl", p, env);
>
> p = scheme_make_folding_prim(unsafe_extfl_to_fx, "unsafe-extfl->fx", 1, 1, 1);
> - if (MZ_LONG_DOUBLE_AND(1))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(1))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1460,7 +1467,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env)
>
> p = scheme_make_immed_prim(unsafe_extflvector_length, "unsafe-extflvector-length",
> 1, 1);
> - if (MZ_LONG_DOUBLE_AND(1))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(1))
> flags = SCHEME_PRIM_IS_UNARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1471,7 +1478,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env)
>
> p = scheme_make_immed_prim(unsafe_extflvector_ref, "unsafe-extflvector-ref",
> 2, 2);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_BINARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1483,7 +1490,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env)
>
> p = scheme_make_immed_prim(unsafe_extflvector_set, "unsafe-extflvector-set!",
> 3, 3);
> - if (MZ_LONG_DOUBLE_AND(1))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(1))
> flags = SCHEME_PRIM_IS_NARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1493,7 +1500,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env)
>
> p = scheme_make_immed_prim(extfl_ref, "unsafe-f80vector-ref",
> 2, 2);
> - if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
> flags = SCHEME_PRIM_IS_BINARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1505,7 +1512,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env)
>
> p = scheme_make_immed_prim(extfl_set, "unsafe-f80vector-set!",
> 3, 3);
> - if (MZ_LONG_DOUBLE_AND(1))
> + if (MZ_LONG_DOUBLE_AVAIL_AND(1))
> flags = SCHEME_PRIM_IS_NARY_INLINED;
> else
> flags = SCHEME_PRIM_SOMETIMES_INLINED;
> @@ -1767,41 +1774,41 @@ Scheme_Object *scheme_make_double(double d)
> }
>
> #ifdef MZ_LONG_DOUBLE
> -XFORM_NONGCING static MZ_INLINE int long_minus_zero_p(long double d)
> +XFORM_NONGCING static MZ_INLINE int long_minus_zero_p(long_double d)
> {
> - return (1 / d) < 0;
> + return long_double_less(long_double_div(get_long_double_1(), d), get_long_double_zero());
> }
>
> -int scheme_long_minus_zero_p(long double d)
> +int scheme_long_minus_zero_p(long_double d)
> {
> return long_minus_zero_p(d);
> }
>
> -long double scheme_real_to_long_double(Scheme_Object *r)
> +long_double scheme_real_to_long_double(Scheme_Object *r)
> {
> if (SCHEME_INTP(r))
> - return (long double)SCHEME_INT_VAL(r);
> + return long_double_from_int(SCHEME_INT_VAL(r));
> else if (SCHEME_DBLP(r))
> - return (long double)SCHEME_DBL_VAL(r);
> + return long_double_from_double(SCHEME_DBL_VAL(r));
> else if (SCHEME_LONG_DBLP(r))
> return SCHEME_LONG_DBL_VAL(r);
> #ifdef MZ_USE_SINGLE_FLOATS
> else if (SCHEME_FLTP(r))
> - return (long double)SCHEME_FLT_VAL(r);
> + return long_double_from_float(SCHEME_FLT_VAL(r));
> #endif
> else if (SCHEME_BIGNUMP(r))
> return scheme_bignum_to_long_double(r);
> else if (SCHEME_RATIONALP(r))
> return scheme_rational_to_long_double(r);
> else
> - return 0.0L;
> + return get_long_double_zero();
> }
>
> -Scheme_Object *scheme_make_long_double(long double d)
> +Scheme_Object *scheme_make_long_double(long_double d)
> {
> GC_CAN_IGNORE Scheme_Long_Double *sd;
>
> - if (d == 0.0L) {
> + if (long_double_eqv(d, get_long_double_zero())) {
> if (long_minus_zero_p(d))
> return scheme_nzerol;
> #ifdef NAN_EQUALS_ANYTHING
> @@ -1985,7 +1992,7 @@ static Scheme_Object *
> extflonum_available_p(int argc, Scheme_Object *argv[])
> {
> #ifdef MZ_LONG_DOUBLE
> - return scheme_true;
> + return (long_double_available() ? scheme_true : scheme_false);
> #else
> return scheme_false;
> #endif
> @@ -2032,12 +2039,9 @@ real_to_double_flonum (int argc, Scheme_Object *argv[])
> static Scheme_Object *
> real_to_long_double_flonum (int argc, Scheme_Object *argv[])
> {
> + CHECK_MZ_LONG_DOUBLE_UNSUPPORTED("real->extfl");
> #ifdef MZ_LONG_DOUBLE
> return scheme_TO_LONG_DOUBLE(argv[0]);
> -#else
> - scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
> - "real->extfl: " NOT_SUPPORTED_STR);
> - return NULL;
> #endif
> }
>
> @@ -2510,42 +2514,42 @@ double scheme_double_floor(double x) { return floor(x); }
> double scheme_double_ceiling(double x) { return ceil(x); }
>
> #ifdef MZ_LONG_DOUBLE
> -XFORM_NONGCING static long double SCH_ROUNDL(long double d)
> +XFORM_NONGCING static long_double SCH_ROUNDL(long_double d)
> {
> - long double i, frac;
> + long_double i, frac;
> int invert;
>
> #ifdef FMOD_CAN_RETURN_POS_ZERO
> - if ((d == 0.0L) && long_minus_zero_p(d))
> + if (long_double_eqv(d, get_long_double_zero()) && long_minus_zero_p(d))
> return d;
> #endif
>
> - if (d < 0.0L) {
> - d = -d;
> + if (long_double_less(d, get_long_double_zero())) {
> + d = long_double_neg(d);
> invert = 1;
> } else
> invert = 0;
>
> - frac = modfl(d, &i);
> - if (frac < 0.5L)
> + frac = long_double_modf(d, &i);
> + if (long_double_less(frac, get_long_double_one_half()))
> d = i;
> - else if (frac > 0.5L)
> - d = i + 1;
> - else if (fmodl(i, 2.0L) != 0.0L)
> - d = i + 1;
> + else if (long_double_greater(frac, get_long_double_one_half()))
> + d = long_double_plus(i, get_long_double_1());
> + else if (!long_double_eqv(long_double_fmod(i, get_long_double_2()), get_long_double_zero()))
> + d = long_double_plus(i, get_long_double_1());
> else
> d = i;
>
> if (invert)
> - d = -d;
> + d = long_double_neg(d);
>
> return d;
> }
>
> -long double scheme_long_double_truncate(long double x) { return truncl(x); }
> -long double scheme_long_double_round(long double x) { return SCH_ROUNDL(x); }
> -long double scheme_long_double_floor(long double x) { return floorl(x); }
> -long double scheme_long_double_ceiling(long double x) { return ceill(x); }
> +long_double scheme_long_double_truncate(long_double x) { return long_double_trunc(x); }
> +long_double scheme_long_double_round(long_double x) { return SCH_ROUNDL(x); }
> +long_double scheme_long_double_floor(long_double x) { return long_double_floor(x); }
> +long_double scheme_long_double_ceiling(long_double x) { return long_double_ceil(x); }
> #endif
>
> #ifdef MZ_USE_SINGLE_FLOATS
> @@ -2922,6 +2926,24 @@ static double SCH_ATAN(double v)
> return v;
> }
>
> +static double SCH_ATAN2(double v, double v2)
> +{
> +#ifdef ATAN2_DOESNT_WORK_WITH_INFINITIES
> + if (MZ_IS_INFINITY(v) && MZ_IS_INFINITY(v2)) {
> + v = MZ_IS_POS_INFINITY(v) ? 1.0 : -1.0;
> + v2 = MZ_IS_POS_INFINITY(v2) ? 1.0 : -1.0;
> + }
> +#endif
> +
> +#ifdef ATAN2_DOESNT_WORK_WITH_NAN
> + if (MZ_IS_NAN(v) || MZ_IS_NAN(v2))
> + return scheme_nan_object;
> +#endif
> +
> + return atan2(v, v2);
> +}
> +
> +
> #ifdef LOG_ZERO_ISNT_NEG_INF
> static double SCH_LOG(double d) { if (d == 0.0) return scheme_minus_infinity_val; else return log(d); }
> #else
> @@ -2939,14 +2961,14 @@ double scheme_double_log(double x) { return SCH_LOG(x); }
> double scheme_double_exp(double x) { return exp(x); }
>
> #ifdef MZ_LONG_DOUBLE
> -long double scheme_long_double_sin(long double x) { return sinl(x); }
> -long double scheme_long_double_cos(long double x) { return cosl(x); }
> -long double scheme_long_double_tan(long double x) { return tanl(x); }
> -long double scheme_long_double_asin(long double x) { return asinl(x); }
> -long double scheme_long_double_acos(long double x) { return acosl(x); }
> -long double scheme_long_double_atan(long double x) { return atanl(x); }
> -long double scheme_long_double_log(long double x) { return logl(x); }
> -long double scheme_long_double_exp(long double x) { return exp(x); }
> +long_double scheme_long_double_sin(long_double x) { return long_double_sin(x); }
> +long_double scheme_long_double_cos(long_double x) { return long_double_cos(x); }
> +long_double scheme_long_double_tan(long_double x) { return long_double_tan(x); }
> +long_double scheme_long_double_asin(long_double x) { return long_double_asin(x); }
> +long_double scheme_long_double_acos(long_double x) { return long_double_acos(x); }
> +long_double scheme_long_double_atan(long_double x) { return long_double_atan(x); }
> +long_double scheme_long_double_log(long_double x) { return long_double_log(x); }
> +long_double scheme_long_double_exp(long_double x) { return long_double_exp(x); }
> #endif
>
>
> @@ -3078,19 +3100,7 @@ atan_prim (int argc, Scheme_Object *argv[])
> }
> }
>
> -#ifdef ATAN2_DOESNT_WORK_WITH_INFINITIES
> - if (MZ_IS_INFINITY(v) && MZ_IS_INFINITY(v2)) {
> - v = MZ_IS_POS_INFINITY(v) ? 1.0 : -1.0;
> - v2 = MZ_IS_POS_INFINITY(v2) ? 1.0 : -1.0;
> - }
> -#endif
> -
> -#ifdef ATAN2_DOESNT_WORK_WITH_NAN
> - if (MZ_IS_NAN(v) || MZ_IS_NAN(v2))
> - return scheme_nan_object;
> -#endif
> -
> - v = atan2(v, v2);
> + v = SCH_ATAN2(v, v2);
> } else { /* 1-argument case */
> if (argv[0] == zeroi)
> return zeroi;
> @@ -3258,7 +3268,7 @@ static double protected_pow(double x, double y)
> word while calling pow(); note that the x87 control
> word is thread-specific */
> #ifndef MZ_LONG_DOUBLE
> - to_extended_prec();
> + to_extended_prec();
> #endif
> x = pow(x, y);
> #ifndef MZ_LONG_DOUBLE
> @@ -3268,10 +3278,10 @@ static double protected_pow(double x, double y)
> }
>
> #ifdef MZ_LONG_DOUBLE
> -static long double protected_powl(long double x, long double y)
> +static long_double protected_powl(long_double x, long_double y)
> {
> /* we use extended precision at all */
> - x = powl(x, y);
> + x = long_double_pow(x, y);
> return x;
> }
> #endif
> @@ -3279,7 +3289,7 @@ static long double protected_powl(long double x, long double y)
> #else
> # define protected_pow pow
> # ifdef MZ_LONG_DOUBLE
> -# define protected_powl powl
> +# define protected_powl long_double_pow
> # endif
> #endif
>
> @@ -3373,25 +3383,25 @@ static double sch_pow(double x, double y)
> }
>
> #ifdef MZ_LONG_DOUBLE
> -static long double sch_powl(long double x, long double y)
> +static long_double sch_powl(long_double x, long_double y)
> {
> /* Like sch_pow(), but with an extra case for x < 0 and non-integer y */
>
> - if (x == 1.0L)
> - return 1.0L; /* even for NaN */
> - else if (y == 0.0L)
> - return 1.0L; /* even for NaN */
> + if (long_double_eqv(x, get_long_double_1()))
> + return get_long_double_1(); /* even for NaN */
> + else if (long_double_is_zero(y))
> + return get_long_double_1(); /* even for NaN */
> else if (MZ_IS_LONG_NAN(x))
> return long_not_a_number_val;
> else if (MZ_IS_LONG_NAN(y))
> return long_not_a_number_val;
> - else if (x == 0.0L) {
> + else if (long_double_eqv(x, get_long_double_zero())) {
> int neg = 0;
> - if (y < 0L) {
> + if (long_double_less(y, get_long_double_zero())) {
> neg = 1;
> - y = -y;
> + y = long_double_neg(y);
> }
> - if (fmodl(y, 2.0L) == 1.0L) {
> + if (long_double_eqv(long_double_fmod(y, get_long_double_2()), get_long_double_1())) {
> if (neg) {
> if (long_minus_zero_p(x))
> return scheme_long_minus_infinity_val;
> @@ -3403,45 +3413,45 @@ static long double sch_powl(long double x, long double y)
> if (neg)
> return scheme_long_infinity_val;
> else
> - return 0.0L;
> + return get_long_double_zero();
> }
> } else if (MZ_IS_LONG_POS_INFINITY(y)) {
> - if (x == -1.0L)
> - return 1.0L;
> - else if ((x < 1.0L) && (x > -1.0L))
> - return 0.0L;
> + if (long_double_eqv(x, get_long_double_minus_1()))
> + return get_long_double_1();
> + else if ((long_double_less(x, get_long_double_1())) && (long_double_greater(x, get_long_double_minus_1())))
> + return get_long_double_zero();
> else
> return scheme_long_infinity_val;
> } else if (MZ_IS_LONG_NEG_INFINITY(y)) {
> - if (x == -1.0L)
> - return 1.0L;
> - else if ((x < 1.0L) && (x > -1.0L))
> + if (long_double_eqv(x, get_long_double_minus_1()))
> + return get_long_double_1();
> + else if (long_double_less(x, get_long_double_1()) && (long_double_greater(x, get_long_double_minus_1())))
> return scheme_long_infinity_val;
> else
> - return 0.0L;
> + return get_long_double_zero();
> } else if (MZ_IS_LONG_POS_INFINITY(x)) {
> - if (y < 0.0L)
> - return 0.0L;
> + if (long_double_less(y, get_long_double_zero()))
> + return get_long_double_zero();
> else
> return scheme_long_infinity_val;
> } else if (MZ_IS_LONG_NEG_INFINITY(x)) {
> int neg = 0;
> - if (y < 0.0L) {
> + if (long_double_less(y, get_long_double_zero())) {
> neg = 1;
> - y = -y;
> + y = long_double_neg(y);
> }
> - if (fmodl(y, 2.0L) == 1.0L) {
> + if (long_double_eqv(long_double_fmod(y, get_long_double_2()), get_long_double_1())) {
> if (neg)
> return scheme_long_floating_point_nzero;
> else
> return scheme_long_minus_infinity_val;
> } else {
> if (neg)
> - return 0.0L;
> + return get_long_double_zero();
> else
> return scheme_long_infinity_val;
> }
> - } else if ((x < 0.0L) && (y != floorl(y))) {
> + } else if (long_double_less(x, get_long_double_zero()) && (!long_double_eqv(y, long_double_floor(y)))) {
> /* powl() on some platforms has trouble with this case */
> return long_not_a_number_val;
> } else {
> @@ -3613,7 +3623,7 @@ double scheme_double_expt(double x, double y) {
> }
>
> #ifdef MZ_LONG_DOUBLE
> -long double scheme_long_double_expt(long double x, long double y) {
> +long_double scheme_long_double_expt(long_double x, long_double y) {
> return sch_powl(x, y);
> }
> #endif
> @@ -3801,7 +3811,7 @@ static Scheme_Object *angle(int argc, Scheme_Object *argv[])
> id = TO_DOUBLE_VAL(i);
> rd = TO_DOUBLE_VAL(r);
>
> - v = atan2(id, rd);
> + v = SCH_ATAN2(id, rd);
>
> #ifdef MZ_USE_SINGLE_FLOATS
> if (was_single)
> @@ -3960,13 +3970,13 @@ static Scheme_Object *exact_to_extfl (int argc, Scheme_Object *argv[])
> Scheme_Type t;
>
> if (SCHEME_INTP(o))
> - return scheme_make_long_double(SCHEME_INT_VAL(o));
> + return scheme_make_long_double(long_double_from_int(SCHEME_INT_VAL(o)));
>
> t = _SCHEME_TYPE(o);
> if (t == scheme_float_type)
> - return scheme_make_long_double(SCHEME_FLOAT_VAL(o));
> + return scheme_make_long_double(long_double_from_double(SCHEME_FLOAT_VAL(o)));
> if (t == scheme_double_type)
> - return scheme_make_long_double(SCHEME_DBL_VAL(o));
> + return scheme_make_long_double(long_double_from_double(SCHEME_DBL_VAL(o)));
> if (t == scheme_long_double_type)
> return o;
> if (t == scheme_bignum_type)
> @@ -3985,7 +3995,9 @@ extfl_to_exact (int argc, Scheme_Object *argv[])
> {
> #ifdef MZ_LONG_DOUBLE
> Scheme_Object *o = argv[0], *i;
> - long double d;
> + long_double d;
> +
> + CHECK_MZ_LONG_DOUBLE_UNSUPPORTED("extfl->exact");
>
> if (!SCHEME_LONG_DBLP(o))
> scheme_wrong_type("extfl->exact", "extflonum", 0, argc, argv);
> @@ -3993,8 +4005,8 @@ extfl_to_exact (int argc, Scheme_Object *argv[])
> d = SCHEME_LONG_DBL_VAL(o);
>
> /* Try simple case: */
> - i = scheme_make_integer((intptr_t)d);
> - if ((long double)SCHEME_INT_VAL(i) == d) {
> + i = scheme_make_integer((intptr_t)int_from_long_double(d));
> + if (long_double_eqv_i(int_from_long_double(d), d)) {
> # ifdef NAN_EQUALS_ANYTHING
> if (!MZ_IS_LONG_NAN(d))
> #endif
> @@ -4003,9 +4015,7 @@ extfl_to_exact (int argc, Scheme_Object *argv[])
>
> return scheme_rational_from_long_double(d);
> #else
> - scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
> - "extfl->exact: " NOT_SUPPORTED_STR);
> - return NULL;
> + CHECK_MZ_LONG_DOUBLE_UNSUPPORTED("extfl->exact");
> #endif
> }
>
> @@ -4015,10 +4025,12 @@ extfl_to_inexact (int argc, Scheme_Object *argv[])
> #ifdef MZ_LONG_DOUBLE
> Scheme_Object *o = argv[0];
>
> + CHECK_MZ_LONG_DOUBLE_UNSUPPORTED("extfl->inexact");
> +
> if (!SCHEME_LONG_DBLP(o))
> scheme_wrong_type("extfl->inexact", "extflonum", 0, argc, argv);
>
> - return scheme_make_double(SCHEME_LONG_DBL_VAL(o));
> + return scheme_make_double(double_from_long_double(SCHEME_LONG_DBL_VAL(o)));
> #else
> scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
> "extfl->inexact: " NOT_SUPPORTED_STR);
> @@ -4523,6 +4535,9 @@ Scheme_Object *scheme_checked_flvector_set (int argc, Scheme_Object *argv[])
>
> #ifndef MZ_LONG_DOUBLE
> # define Scheme_Long_Double_Vector void
> +#endif
> +
> +#if !defined(MZ_LONG_DOUBLE) || defined(MZ_LONG_DOUBLE_API_IS_EXTERNAL)
> static Scheme_Object *unsupported(const char *name)
> {
> scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
> @@ -4539,7 +4554,7 @@ Scheme_Long_Double_Vector *scheme_alloc_extflvector(intptr_t size)
>
> vec = (Scheme_Long_Double_Vector *)scheme_malloc_fail_ok(scheme_malloc_atomic_tagged,
> sizeof(Scheme_Long_Double_Vector)
> - + ((size - mzFLEX_DELTA) * sizeof(long double)));
> + + ((size - mzFLEX_DELTA) * sizeof(long_double)));
> vec->iso.so.type = scheme_extflvector_type;
> vec->size = size;
>
> @@ -4575,6 +4590,8 @@ static Scheme_Object *do_extflvector (const char *name, Scheme_Long_Double_Vecto
> #ifdef MZ_LONG_DOUBLE
> int i;
>
> + WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported(name));
> +
> for (i = 0; i < argc; i++) {
> if (!SCHEME_LONG_DBLP(argv[i])) {
> scheme_wrong_contract(name, "extflonum?", i, argc, argv);
> @@ -4612,9 +4629,11 @@ static Scheme_Object *do_make_extflvector (const char *name, int as_shared, int
> #ifdef MZ_LONG_DOUBLE
> Scheme_Long_Double_Vector *vec;
> intptr_t size;
> - long double d;
> + long_double d;
> int i;
>
> + WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported(name));
> +
> if (SCHEME_INTP(argv[0]))
> size = SCHEME_INT_VAL(argv[0]);
> else if (SCHEME_BIGNUMP(argv[0])) {
> @@ -4642,7 +4661,7 @@ static Scheme_Object *do_make_extflvector (const char *name, int as_shared, int
> if (argc > 1)
> d = SCHEME_LONG_DBL_VAL(argv[1]);
> else
> - d = 0.0L;
> + d = get_long_double_zero();
> for (i = 0; i < size; i++) {
> vec->els[i] = d;
> }
> @@ -4666,6 +4685,8 @@ static Scheme_Object *make_shared_extflvector (int argc, Scheme_Object *argv[])
> Scheme_Object *scheme_extflvector_length(Scheme_Object *vec)
> {
> #ifdef MZ_LONG_DOUBLE
> + WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("extflvector-length"));
> +
> if (!SCHEME_EXTFLVECTORP(vec))
> scheme_wrong_contract("extflvector-length", "extflvector?", 0, 1, &vec);
>
> @@ -4678,10 +4699,14 @@ Scheme_Object *scheme_extflvector_length(Scheme_Object *vec)
> static Scheme_Object *extfl_ref (int argc, Scheme_Object *argv[])
> {
> #ifdef MZ_LONG_DOUBLE
> - long double v;
> + long_double v;
> Scheme_Object *p;
> +
> + WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("unsafe-f80vector-ref"));
> +
> p = ((Scheme_Structure *)argv[0])->slots[0];
> - v = ((long double *)SCHEME_CPTR_VAL(p))[SCHEME_INT_VAL(argv[1])];
> +
> + v = long_double_array_ref(SCHEME_CPTR_VAL(p), SCHEME_INT_VAL(argv[1]));
> return scheme_make_long_double(v);
> #else
> return unsupported("unsafe-f80vector-ref");
> @@ -4693,7 +4718,8 @@ static Scheme_Object *extfl_set (int argc, Scheme_Object *argv[])
> #ifdef MZ_LONG_DOUBLE
> Scheme_Object *p;
> p = ((Scheme_Structure *)argv[0])->slots[0];
> - ((long double *)SCHEME_CPTR_VAL(p))[SCHEME_INT_VAL(argv[1])] = SCHEME_LONG_DBL_VAL(argv[2]);
> +
> + long_double_array_set(SCHEME_CPTR_VAL(p), SCHEME_INT_VAL(argv[1]), SCHEME_LONG_DBL_VAL(argv[2]));
> return scheme_void;
> #else
> return unsupported("unsafe-f80vector-set!");
> @@ -4708,10 +4734,12 @@ static Scheme_Object *extflvector_length (int argc, Scheme_Object *argv[])
> Scheme_Object *scheme_checked_extflvector_ref (int argc, Scheme_Object *argv[])
> {
> #ifdef MZ_LONG_DOUBLE
> - long double d;
> + long_double d;
> Scheme_Object *vec;
> intptr_t len, pos;
>
> + WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("extflvector-ref"));
> +
> vec = argv[0];
> if (!SCHEME_EXTFLVECTORP(vec))
> scheme_wrong_contract("extflvector-ref", "extflvector?", 0, argc, argv);
> @@ -4740,6 +4768,8 @@ Scheme_Object *scheme_checked_extflvector_set (int argc, Scheme_Object *argv[])
> Scheme_Object *vec;
> intptr_t len, pos;
>
> + WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("extflvector-set!"));
> +
> vec = argv[0];
> if (!SCHEME_EXTFLVECTORP(vec))
> scheme_wrong_contract("extflvector-set!", "extflvector?", 0, argc, argv);
> @@ -5061,9 +5091,10 @@ static Scheme_Object *fx_to_extfl (int argc, Scheme_Object *argv[])
> {
> #ifdef MZ_LONG_DOUBLE
> intptr_t v;
> + WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("fx->extfl"));
> if (!SCHEME_INTP(argv[0])) scheme_wrong_contract("fx->extfl", "fixnum?", 0, argc, argv);
> v = SCHEME_INT_VAL(argv[0]);
> - return scheme_make_long_double(v);
> + return scheme_make_long_double(long_double_from_int(v));
> #else
> return unsupported("fx->extfl");
> #endif
> @@ -5072,17 +5103,18 @@ static Scheme_Object *fx_to_extfl (int argc, Scheme_Object *argv[])
> static Scheme_Object *extfl_to_fx (int argc, Scheme_Object *argv[])
> {
> #ifdef MZ_LONG_DOUBLE
> - long double d;
> + long_double d;
> intptr_t v;
> Scheme_Object *o;
>
> - if (!SCHEME_LONG_DBLP(argv[0])
> - /* && !scheme_is_integer(argv[0]) */)
> + WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("extfl->fx"));
> +
> + if (!SCHEME_LONG_DBLP(argv[0]))
> scheme_wrong_contract("extfl->fx", "(and/c extflonum?)", 0, argc, argv);
>
> d = SCHEME_LONG_DBL_VAL(argv[0]);
> - v = (intptr_t)d;
> - if ((long double)v == d) {
> + v = (intptr_t)int_from_long_double(d);
> + if (long_double_eqv_i(v, d)) {
> o = scheme_make_integer_value(v);
> if (SCHEME_INTP(o))
> return o;
> @@ -5101,7 +5133,8 @@ static Scheme_Object *extfl_to_fx (int argc, Scheme_Object *argv[])
> # define SAFE_EXTFL(op) \
> static Scheme_Object * extfl_ ## op (int argc, Scheme_Object *argv[]) \
> { \
> - long double v; \
> + long_double v; \
> + WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("extfl" #op)); \
> if (!SCHEME_LONG_DBLP(argv[0])) scheme_wrong_contract("extfl" #op, "extflonum?", 0, argc, argv); \
> v = scheme_long_double_ ## op (SCHEME_LONG_DBL_VAL(argv[0])); \
> return scheme_make_long_double(v); \
> @@ -5131,7 +5164,7 @@ SAFE_EXTFL(log)
> # define SAFE_BIN_EXTFL(op) \
> static Scheme_Object * extfl_ ## op (int argc, Scheme_Object *argv[]) \
> { \
> - long double v; \
> + long_double v; \
> if (!SCHEME_LONG_DBLP(argv[0])) scheme_wrong_contract("extfl" #op, "extflonum?", 0, argc, argv); \
> if (!SCHEME_LONG_DBLP(argv[1])) scheme_wrong_contract("extfl" #op, "extflonum?", 1, argc, argv); \
> v = scheme_long_double_ ## op (SCHEME_LONG_DBL_VAL(argv[0]), SCHEME_LONG_DBL_VAL(argv[1])); \
> @@ -5234,7 +5267,7 @@ static Scheme_Object *unsafe_fx_to_extfl (int argc, Scheme_Object *argv[])
> intptr_t v;
> if (scheme_current_thread->constant_folding) return exact_to_extfl(argc, argv);
> v = SCHEME_INT_VAL(argv[0]);
> - return scheme_make_long_double(v);
> + return scheme_make_long_double(long_double_from_int(v));
> #else
> return fx_to_extfl(argc, argv);
> #endif
> @@ -5245,7 +5278,7 @@ static Scheme_Object *unsafe_extfl_to_fx (int argc, Scheme_Object *argv[])
> #ifdef MZ_LONG_DOUBLE
> intptr_t v;
> if (scheme_current_thread->constant_folding) return extfl_to_exact(argc, argv);
> - v = (intptr_t)(SCHEME_LONG_DBL_VAL(argv[0]));
> + v = (intptr_t)int_from_long_double(SCHEME_LONG_DBL_VAL(argv[0]));
> return scheme_make_integer(v);
> #else
> return extfl_to_fx(argc, argv);
> @@ -5265,7 +5298,7 @@ static Scheme_Object *unsafe_extflvector_ref (int argc, Scheme_Object *argv[])
> {
> #ifdef MZ_LONG_DOUBLE
> intptr_t pos;
> - long double d;
> + long_double d;
>
> pos = SCHEME_INT_VAL(argv[1]);
> d = SCHEME_EXTFLVEC_ELS(argv[0])[pos];
> @@ -5389,6 +5422,7 @@ static Scheme_Object *unsafe_flimag_part (int argc, Scheme_Object *argv[])
> static Scheme_Object *integer_to_extfl (int argc, Scheme_Object *argv[])
> {
> #ifdef MZ_LONG_DOUBLE
> + WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("->extfl"));
> if (SCHEME_INTP(argv[0])
> || SCHEME_BIGNUMP(argv[0])) {
> return exact_to_extfl(argc, argv);
> @@ -5404,6 +5438,7 @@ static Scheme_Object *integer_to_extfl (int argc, Scheme_Object *argv[])
> static Scheme_Object *extfl_to_integer (int argc, Scheme_Object *argv[])
> {
> #ifdef MZ_LONG_DOUBLE
> + WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("extfl->exact-integer"));
> if (SCHEME_LONG_DBLP(argv[0])) {
> Scheme_Object *o;
> o = extfl_to_exact(argc, argv);
> @@ -5417,3 +5452,7 @@ static Scheme_Object *extfl_to_integer (int argc, Scheme_Object *argv[])
> return unsupported("extfl->exact-integer");
> #endif
> }
> +
> +#ifdef MZ_LONG_DOUBLE_API_IS_EXTERNAL
> +# include "longdouble/longdouble.c"
> +#endif
>
> src/racket/src/numcomp.c
> ~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/numcomp.c
> +++ NEW/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)
>
>
> src/racket/src/numstr.c
> ~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/numstr.c
> +++ NEW/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);
>
> @@ -1287,19 +1283,26 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
> #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];
>
> src/racket/src/optimize.c
> ~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/optimize.c
> +++ NEW/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
> }
>
> src/racket/src/ratfloat.inc
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/ratfloat.inc
> +++ NEW/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
>
> src/racket/src/rational.c
> ~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/rational.c
> +++ NEW/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<y
> +#define FP_IS_ZERO(x) x==0.0
> +#define FP_TYPE_FROM_INT(x) (FP_TYPE)x
> #define SCHEME_RATIONAL_TO_FLOAT scheme_rational_to_double
> #define SCHEME_RATIONAL_FROM_FLOAT scheme_rational_from_double
> #define SCHEME_BIGNUM_TO_FLOAT_INF_INFO scheme_bignum_to_double_inf_info
> @@ -528,6 +535,13 @@ Scheme_Object *scheme_rational_sqrt(const Scheme_Object *o)
>
> #ifdef MZ_USE_SINGLE_FLOATS
> #define FP_TYPE float
> +#define FP_MULT(x, y) x*y
> +#define FP_DIV(x, y) x/y
> +#define FP_NEG(x) -x
> +#define FP_EQV(x,y) x==y
> +#define FP_LESS(x, y) x<y
> +#define FP_TYPE_FROM_INT(x) (FP_TYPE)x
> +#define FP_IS_ZERO(x) x==0.0
> #define SCHEME_RATIONAL_TO_FLOAT scheme_rational_to_float
> #define SCHEME_RATIONAL_FROM_FLOAT scheme_rational_from_float
> #define SCHEME_BIGNUM_TO_FLOAT_INF_INFO scheme_bignum_to_float_inf_info
> @@ -540,19 +554,26 @@ Scheme_Object *scheme_rational_sqrt(const Scheme_Object *o)
> #endif
>
> #ifdef MZ_LONG_DOUBLE
> -# define FP_TYPE long double
> +# define FP_TYPE long_double
> +# define FP_MULT(x, y) long_double_mult(x,y)
> +# define FP_DIV(x, y) long_double_div(x,y)
> +# define FP_NEG(x) long_double_neg(x)
> +# define FP_EQV(x,y) long_double_eqv(x,y)
> +# define FP_LESS(x, y) long_double_less(x,y)
> +# define FP_TYPE_FROM_INT(x) long_double_from_int(x)
> +# define FP_IS_ZERO(x) long_double_is_zero(x)
> # define SCHEME_RATIONAL_TO_FLOAT scheme_rational_to_long_double
> # define SCHEME_RATIONAL_FROM_FLOAT scheme_rational_from_long_double
> # define SCHEME_BIGNUM_TO_FLOAT_INF_INFO scheme_bignum_to_long_double_inf_info
> # define SCHEME_CHECK_FLOAT scheme_check_long_double
> # define SCHEME_BIGNUM_FROM_FLOAT scheme_bignum_from_long_double
> -# define DO_FLOAT_DIV scheme__do_long_double_div
> # define FLOAT_E_MIN -16383
> # define FLOAT_M_BITS 64
> -# define FP_ZEROx 0L
> -# define FP_POWx powl
> -# define FP_MODFx modfl
> -# define FP_FREXPx frexpl
> +# define FP_ZEROx get_long_double_zero()
> +# define FP_POWx pow
> +# define FP_MODFx long_double_modf
> +# define FP_FREXPx long_double_frexp
> +# define FP_LDEXP long_double_ldexp
> # define FP_DOUBLE_TYPE FP_TYPE
> #include "ratfloat.inc"
> #endif
>
> src/racket/src/schemef.h
> ~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/schemef.h
> +++ NEW/src/racket/src/schemef.h
> @@ -34,7 +34,7 @@
> /*========================================================================*/
> /* setjmpup (continuations) */
> /*========================================================================*/
> -
> +#include "longdouble/longdouble.h"
> MZ_EXTERN void scheme_init_jmpup_buf(Scheme_Jumpup_Buf *b);
> MZ_EXTERN int scheme_setjmpup_relative(Scheme_Jumpup_Buf *b, void *base,
> void * volatile start, struct Scheme_Cont *cont);
> @@ -619,7 +619,7 @@ MZ_EXTERN Scheme_Object *scheme_make_integer_value_from_long_halves(uintptr_t lo
> MZ_EXTERN Scheme_Object *scheme_make_integer_value_from_unsigned_long_halves(uintptr_t lowhalf, uintptr_t hihalf);
> MZ_EXTERN Scheme_Object *scheme_make_double(double d);
> #ifdef MZ_LONG_DOUBLE
> -MZ_EXTERN Scheme_Object *scheme_make_long_double(long double d);
> +MZ_EXTERN Scheme_Object *scheme_make_long_double(long_double d);
> #endif
> #ifdef MZ_USE_SINGLE_FLOATS
> MZ_EXTERN Scheme_Object *scheme_make_float(float f) ;
> @@ -643,7 +643,7 @@ XFORM_NONGCING MZ_EXTERN int scheme_get_unsigned_long_long_val(Scheme_Object *o,
>
> MZ_EXTERN double scheme_real_to_double(Scheme_Object *r);
> #ifdef MZ_LONG_DOUBLE
> -MZ_EXTERN long double scheme_real_to_long_double(Scheme_Object *r);
> +MZ_EXTERN long_double scheme_real_to_long_double(Scheme_Object *r);
> #endif
>
> MZ_EXTERN Scheme_Object *scheme_make_cptr(void *cptr, Scheme_Object *typetag);
> @@ -707,8 +707,8 @@ MZ_EXTERN Scheme_Object *scheme_make_bignum_from_unsigned_long_long(umzlonglong
> XFORM_NONGCING MZ_EXTERN double scheme_bignum_to_double(const Scheme_Object *n);
> MZ_EXTERN Scheme_Object *scheme_bignum_from_double(double d);
> #ifdef MZ_LONG_DOUBLE
> -XFORM_NONGCING MZ_EXTERN long double scheme_bignum_to_long_double(const Scheme_Object *n);
> -MZ_EXTERN Scheme_Object *scheme_bignum_from_long_double(long double d);
> +XFORM_NONGCING MZ_EXTERN long_double scheme_bignum_to_long_double(const Scheme_Object *n);
> +MZ_EXTERN Scheme_Object *scheme_bignum_from_long_double(long_double d);
> #endif
> #ifdef MZ_USE_SINGLE_FLOATS
> XFORM_NONGCING MZ_EXTERN float scheme_bignum_to_float(const Scheme_Object *n);
> @@ -731,8 +731,8 @@ MZ_EXTERN Scheme_Object *scheme_make_rational(const Scheme_Object *r, const Sche
> MZ_EXTERN double scheme_rational_to_double(const Scheme_Object *n);
> MZ_EXTERN Scheme_Object *scheme_rational_from_double(double d);
> #ifdef MZ_LONG_DOUBLE
> -MZ_EXTERN long double scheme_rational_to_long_double(const Scheme_Object *n);
> -MZ_EXTERN Scheme_Object *scheme_rational_from_long_double(long double d);
> +MZ_EXTERN long_double scheme_rational_to_long_double(const Scheme_Object *n);
> +MZ_EXTERN Scheme_Object *scheme_rational_from_long_double(long_double d);
> #endif
> #ifdef MZ_USE_SINGLE_FLOATS
> MZ_EXTERN float scheme_rational_to_float(const Scheme_Object *n);
>
> src/racket/src/schemex.h
> ~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/schemex.h
> +++ NEW/src/racket/src/schemex.h
> @@ -16,6 +16,7 @@ typedef struct {
> /*========================================================================*/
> /* setjmpup (continuations) */
> /*========================================================================*/
> +#include "longdouble/longdouble.h"
> void (*scheme_init_jmpup_buf)(Scheme_Jumpup_Buf *b);
> int (*scheme_setjmpup_relative)(Scheme_Jumpup_Buf *b, void *base,
> void * volatile start, struct Scheme_Cont *cont);
> @@ -497,7 +498,7 @@ Scheme_Object *(*scheme_make_integer_value_from_long_halves)(uintptr_t lowhalf,
> Scheme_Object *(*scheme_make_integer_value_from_unsigned_long_halves)(uintptr_t lowhalf, uintptr_t hihalf);
> Scheme_Object *(*scheme_make_double)(double d);
> #ifdef MZ_LONG_DOUBLE
> -Scheme_Object *(*scheme_make_long_double)(long double d);
> +Scheme_Object *(*scheme_make_long_double)(long_double d);
> #endif
> #ifdef MZ_USE_SINGLE_FLOATS
> Scheme_Object *(*scheme_make_float)(float f) ;
> @@ -518,7 +519,7 @@ int (*scheme_get_long_long_val)(Scheme_Object *o, mzlonglong *v);
> int (*scheme_get_unsigned_long_long_val)(Scheme_Object *o, umzlonglong *v);
> double (*scheme_real_to_double)(Scheme_Object *r);
> #ifdef MZ_LONG_DOUBLE
> -long double;
> +long_double (*scheme_real_to_long_double)(Scheme_Object *r);
> #endif
> Scheme_Object *(*scheme_make_cptr)(void *cptr, Scheme_Object *typetag);
> Scheme_Object *(*scheme_make_offset_cptr)(void *cptr, intptr_t offset, Scheme_Object *typetag);
> @@ -571,8 +572,8 @@ Scheme_Object *(*scheme_make_bignum_from_unsigned_long_long)(umzlonglong v);
> double (*scheme_bignum_to_double)(const Scheme_Object *n);
> Scheme_Object *(*scheme_bignum_from_double)(double d);
> #ifdef MZ_LONG_DOUBLE
> -long double;
> -Scheme_Object *(*scheme_bignum_from_long_double)(long double d);
> +long_double (*scheme_bignum_to_long_double)(const Scheme_Object *n);
> +Scheme_Object *(*scheme_bignum_from_long_double)(long_double d);
> #endif
> #ifdef MZ_USE_SINGLE_FLOATS
> float (*scheme_bignum_to_float)(const Scheme_Object *n);
> @@ -593,8 +594,8 @@ Scheme_Object *(*scheme_make_rational)(const Scheme_Object *r, const Scheme_Obje
> double (*scheme_rational_to_double)(const Scheme_Object *n);
> Scheme_Object *(*scheme_rational_from_double)(double d);
> #ifdef MZ_LONG_DOUBLE
> -long double;
> -Scheme_Object *(*scheme_rational_from_long_double)(long double d);
> +long_double (*scheme_rational_to_long_double)(const Scheme_Object *n);
> +Scheme_Object *(*scheme_rational_from_long_double)(long_double d);
> #endif
> #ifdef MZ_USE_SINGLE_FLOATS
> float (*scheme_rational_to_float)(const Scheme_Object *n);
>
> src/racket/src/schpriv.h
> ~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/schpriv.h
> +++ NEW/src/racket/src/schpriv.h
> @@ -19,6 +19,7 @@
> #define __mzscheme_private__
>
> #include "scheme.h"
> +#include "longdouble/longdouble.h"
>
> #ifdef CIL_ANALYSIS
> #define ROSYM __attribute__((__ROSYM__))
> @@ -1864,6 +1865,23 @@ intptr_t scheme_get_semaphore_init(const char *who, int n, Scheme_Object **p);
> # define MZ_LONG_DOUBLE_AND(x) 0
> #endif
>
> +#ifdef MZ_LONG_DOUBLE_API_IS_EXTERNAL
> +# define MZ_LONG_DOUBLE_AVAIL_AND(x) MZ_LONG_DOUBLE_AND(long_double_available() && (x))
> +# define WHEN_LONG_DOUBLE_UNSUPPORTED(what) \
> + if (!long_double_available()) { \
> + what; \
> + }
> +# define CHECK_MZ_LONG_DOUBLE_UNSUPPORTED(who) \
> + if (!long_double_available()) { \
> + scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, who ": " NOT_SUPPORTED_STR); \
> + ESCAPED_BEFORE_HERE; \
> + }
> +#else
> +# define WHEN_LONG_DOUBLE_UNSUPPORTED(what) /* empty */
> +# define CHECK_MZ_LONG_DOUBLE_UNSUPPORTED(who) /* empty */
> +# define MZ_LONG_DOUBLE_AVAIL_AND(x) MZ_LONG_DOUBLE_AND(x)
> +#endif
> +
> void scheme_configure_floating_point(void);
>
> /****** Bignums *******/
> @@ -1902,7 +1920,7 @@ XFORM_NONGCING Scheme_Object *scheme_make_small_bignum(intptr_t v, Small_Bignum
> char *scheme_number_to_string(int radix, Scheme_Object *obj);
> char *scheme_double_to_string (double d, char* s, int slen, int was_single, int *used_buffer);
> #ifdef MZ_LONG_DOUBLE
> -char *scheme_long_double_to_string (long double d, char* s, int slen, int *used_buffer);
> +char *scheme_long_double_to_string (long_double d, char* s, int slen, int *used_buffer);
> #endif
>
> Scheme_Object *scheme_bignum_copy(const Scheme_Object *n);
> @@ -1939,7 +1957,7 @@ Scheme_Object *scheme_bignum_shift(const Scheme_Object *a, intptr_t shift);
>
> XFORM_NONGCING double scheme_bignum_to_double_inf_info(const Scheme_Object *n, intptr_t just_use, intptr_t *only_need);
> #ifdef MZ_LONG_DOUBLE
> -XFORM_NONGCING long double scheme_bignum_to_long_double_inf_info(const Scheme_Object *n, intptr_t just_use, intptr_t *only_need);
> +XFORM_NONGCING long_double scheme_bignum_to_long_double_inf_info(const Scheme_Object *n, intptr_t just_use, intptr_t *only_need);
> #endif
> #ifdef MZ_USE_SINGLE_FLOATS
> XFORM_NONGCING float scheme_bignum_to_float_inf_info(const Scheme_Object *n, intptr_t just_use, intptr_t *only_need);
> @@ -2023,7 +2041,7 @@ XFORM_NONGCING int scheme_is_complex_exact(const Scheme_Object *o);
>
> int scheme_check_double(const char *where, double v, const char *dest);
> #ifdef MZ_LONG_DOUBLE
> -int scheme_check_long_double(const char *where, long double v, const char *dest);
> +int scheme_check_long_double(const char *where, long_double v, const char *dest);
> #endif
> #ifdef MZ_USE_SINGLE_FLOATS
> int scheme_check_float(const char *where, float v, const char *dest);
> @@ -2035,8 +2053,8 @@ double scheme_get_val_as_double(const Scheme_Object *n);
> XFORM_NONGCING int scheme_minus_zero_p(double d);
>
> #ifdef MZ_LONG_DOUBLE
> -long double scheme_get_val_as_long_double(const Scheme_Object *n);
> -XFORM_NONGCING int scheme_long_minus_zero_p(long double d);
> +long_double scheme_get_val_as_long_double(const Scheme_Object *n);
> +XFORM_NONGCING int scheme_long_minus_zero_p(long_double d);
> #else
> # define scheme_long_minus_zero_p(d) scheme_minus_zero_p(d)
> #endif
> @@ -2107,10 +2125,17 @@ extern int scheme_is_nan(double);
> # endif
> #endif
>
> -#define MZ_IS_LONG_INFINITY(d) MZ_IS_INFINITY(d)
> -#define MZ_IS_LONG_POS_INFINITY(d) MZ_IS_POS_INFINITY(d)
> -#define MZ_IS_LONG_NEG_INFINITY(d) MZ_IS_NEG_INFINITY(d)
> -#define MZ_IS_LONG_NAN(d) MZ_IS_NAN(d)
> +#ifdef MZ_LONG_DOUBLE_API_IS_EXTERNAL
> +# define MZ_IS_LONG_INFINITY(d) long_double_is_infinity(d)
> +# define MZ_IS_LONG_POS_INFINITY(d) long_double_is_pos_infinity(d)
> +# define MZ_IS_LONG_NEG_INFINITY(d) long_double_is_neg_infinity(d)
> +# define MZ_IS_LONG_NAN(d) long_double_is_nan(d)
> +#else
> +# define MZ_IS_LONG_INFINITY(d) MZ_IS_INFINITY(d)
> +# define MZ_IS_LONG_POS_INFINITY(d) MZ_IS_POS_INFINITY(d)
> +# define MZ_IS_LONG_NEG_INFINITY(d) MZ_IS_NEG_INFINITY(d)
> +# define MZ_IS_LONG_NAN(d) MZ_IS_NAN(d)
> +#endif
>
> #ifndef MZ_IS_INFINITY
> # define MZ_IS_INFINITY(d) (MZ_IS_POS_INFINITY(d) || MZ_IS_NEG_INFINITY(d))
> @@ -2124,9 +2149,9 @@ extern double scheme_floating_point_nzero;
> extern Scheme_Object *scheme_zerod, *scheme_nzerod, *scheme_pi, *scheme_half_pi, *scheme_plus_i, *scheme_minus_i;
> extern Scheme_Object *scheme_inf_object, *scheme_minus_inf_object, *scheme_nan_object;
> #ifdef MZ_LONG_DOUBLE
> -extern long double scheme_long_infinity_val, scheme_long_minus_infinity_val;
> -extern long double scheme_long_floating_point_zero;
> -extern long double scheme_long_floating_point_nzero;
> +extern long_double scheme_long_infinity_val, scheme_long_minus_infinity_val;
> +extern long_double scheme_long_floating_point_zero;
> +extern long_double scheme_long_floating_point_nzero;
> extern Scheme_Object *scheme_zerol, *scheme_nzerol, *scheme_long_scheme_pi;
> extern Scheme_Object *scheme_long_inf_object, *scheme_long_minus_inf_object, *scheme_long_nan_object;
> #endif
> @@ -2238,19 +2263,19 @@ double scheme_double_expt(double x, double y);
>
> /***** extflonums *****/
> #ifdef MZ_LONG_DOUBLE
> -long double scheme_long_double_truncate(long double x);
> -long double scheme_long_double_round(long double x);
> -long double scheme_long_double_floor(long double x);
> -long double scheme_long_double_ceiling(long double x);
> -long double scheme_long_double_sin(long double x);
> -long double scheme_long_double_cos(long double x);
> -long double scheme_long_double_tan(long double x);
> -long double scheme_long_double_asin(long double x);
> -long double scheme_long_double_acos(long double x);
> -long double scheme_long_double_atan(long double x);
> -long double scheme_long_double_log(long double x);
> -long double scheme_long_double_exp(long double x);
> -long double scheme_long_double_expt(long double x, long double y);
> +long_double scheme_long_double_truncate(long_double x);
> +long_double scheme_long_double_round(long_double x);
> +long_double scheme_long_double_floor(long_double x);
> +long_double scheme_long_double_ceiling(long_double x);
> +long_double scheme_long_double_sin(long_double x);
> +long_double scheme_long_double_cos(long_double x);
> +long_double scheme_long_double_tan(long_double x);
> +long_double scheme_long_double_asin(long_double x);
> +long_double scheme_long_double_acos(long_double x);
> +long_double scheme_long_double_atan(long_double x);
> +long_double scheme_long_double_log(long_double x);
> +long_double scheme_long_double_exp(long_double x);
> +long_double scheme_long_double_expt(long_double x, long_double y);
> #endif
> /*========================================================================*/
> /* read, eval, print */
> @@ -2569,7 +2594,7 @@ typedef struct Scheme_Current_LWC {
> void *saved_v1;
> double saved_save_fp;
> #ifdef MZ_LONG_DOUBLE
> - long double saved_save_extfp;
> + long_double saved_save_extfp;
> #endif
> } Scheme_Current_LWC;
>
> @@ -3630,6 +3655,11 @@ void scheme_write_proc_context(Scheme_Object *port, int print_width,
> int scheme_is_relative_path(const char *s, intptr_t len, int kind);
> int scheme_is_complete_path(const char *s, intptr_t len, int kind);
>
> +#ifdef DOS_FILE_SYSTEM
> +__declspec(dllexport) wchar_t *scheme_get_dll_path(wchar_t *s);
> +__declspec(dllexport) void scheme_set_dll_path(wchar_t *p);
> +#endif
> +
> Scheme_Object *scheme_get_file_directory(const char *filename);
>
> char *scheme_normal_path_seps(char *s, int *_len, int delta);
>
> src/racket/src/string.c
> ~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/src/racket/src/string.c
> +++ NEW/src/racket/src/string.c
> @@ -79,7 +79,6 @@ static int get_iconv_errno(void)
> # define HAVE_CODESET 1
> # define CODESET 0
> # define ICONV_errno get_iconv_errno()
> -extern wchar_t *scheme_get_dll_path(wchar_t *s);
> static int iconv_ready = 0;
> static void init_iconv()
> {
>
> src/worksp/README
> ~~~~~~~~~~~~~~~~~
> --- OLD/src/worksp/README
> +++ NEW/src/worksp/README
> @@ -139,6 +139,10 @@ pango-1.28.3:
> modules/basic/basic-win32.c:479:
> if (ScriptItemize (wtext, wlen, G_N_ELEMENTS (items) - 1, &control, NULL,
>
> +The "longdouble.dll" library is used to implement extflonums. Its
> +source is "longdouble.c" in the Racket source directory, and it must
> +be compiled using MinGW and with `IMPLEMENTING_MSC_LONGDOUBLE' defined.
> +
> Building Racket3m and GRacket3m
> -------------------------------
>
![[logo]](/logo.png){kind=logo}