This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
Other format: | [Raw text] |
- i686-linux, which has real(10) - sparc-solaris, whichs has real(16) - x86_64-linux, which has real(10) and integer(16) - alpha-linux, which has integer(16)
(I think I got my bases covered; hopefully, I will not have to do that again for some time ;-)
Index: libgfortran/Makefile.am =================================================================== RCS file: /cvsroot/gcc/gcc/libgfortran/Makefile.am,v retrieving revision 1.35 diff -p -u -r1.35 Makefile.am --- libgfortran/Makefile.am 18 May 2005 20:35:25 -0000 1.35 +++ libgfortran/Makefile.am 6 Jun 2005 20:54:23 -0000 @@ -295,7 +295,7 @@ gfor_built_src= $(i_all_c) $(i_any_c) $( $(i_eoshift3_c) $(i_cshift1_c) $(i_reshape_c) $(in_pack_c) $(in_unpack_c) \ $(i_exponent_c) $(i_fraction_c) $(i_nearest_c) $(i_set_exponent_c) \ $(i_pow_c) \ - selected_int_kind.inc selected_real_kind.inc + selected_int_kind.inc selected_real_kind.inc kinds.h # We only use these if libm doesn't contain complex math functions. @@ -415,6 +415,9 @@ I_M4_DEPS=m4/iparm.m4 I_M4_DEPS0=$(I_M4_DEPS) m4/iforeach.m4 I_M4_DEPS1=$(I_M4_DEPS) m4/ifunction.m4 +kinds.h: $(srcdir)/mk-kinds-h.sh + $(SHELL) $(srcdir)/mk-kinds-h.sh '$(FCCOMPILE)' > $@ + selected_int_kind.inc: $(srcdir)/mk-sik-inc.sh $(SHELL) $(srcdir)/mk-sik-inc.sh '$(FCCOMPILE)' > $@ Index: libgfortran/configure.ac =================================================================== RCS file: /cvsroot/gcc/gcc/libgfortran/configure.ac,v retrieving revision 1.27 diff -p -u -r1.27 configure.ac --- libgfortran/configure.ac 21 May 2005 06:44:50 -0000 1.27 +++ libgfortran/configure.ac 6 Jun 2005 20:54:24 -0000 @@ -158,7 +158,7 @@ AC_TYPE_OFF_T AC_STDC_HEADERS AC_HAVE_HEADERS(stdlib.h stdio.h string.h stddef.h math.h unistd.h signal.h) AC_CHECK_HEADERS(time.h sys/params.h sys/time.h sys/times.h sys/resource.h) -AC_CHECK_HEADERS(sys/mman.h sys/types.h sys/stat.h ieeefp.h) +AC_CHECK_HEADERS(sys/mman.h sys/types.h sys/stat.h ieeefp.h sunmath.h) AC_CHECK_HEADER([complex.h],[AC_DEFINE([HAVE_COMPLEX_H], [1], [complex.h exists])]) AC_CHECK_MEMBERS([struct stat.st_blksize]) @@ -169,7 +169,7 @@ AC_CHECK_MEMBERS([struct stat.st_rdev]) AC_CHECK_LIB([m],[csin],[need_math="no"],[need_math="yes"]) # Check for library functions. -AC_CHECK_FUNCS(getrusage times mkstemp strtof snprintf ftruncate chsize) +AC_CHECK_FUNCS(getrusage times mkstemp strtof strtold snprintf ftruncate chsize) AC_CHECK_FUNCS(chdir strerror getlogin gethostname kill link symlink perror) AC_CHECK_FUNCS(sleep time) @@ -195,6 +195,7 @@ AC_CHECK_LIB([m],[frexpf],[AC_DEFINE([HA AC_CHECK_LIB([m],[hypotf],[AC_DEFINE([HAVE_HYPOTF],[1],[libm includes hypotf])]) AC_CHECK_LIB([m],[logf],[AC_DEFINE([HAVE_LOGF],[1],[libm includes logf])]) AC_CHECK_LIB([m],[log10f],[AC_DEFINE([HAVE_LOG10F],[1],[libm includes log10f])]) +AC_CHECK_LIB([m],[log10l],[AC_DEFINE([HAVE_LOG10L],[1],[libm includes log10l])]) AC_CHECK_LIB([m],[nextafter],[AC_DEFINE([HAVE_NEXTAFTER],[1],[libm includes nextafter])]) AC_CHECK_LIB([m],[nextafterf],[AC_DEFINE([HAVE_NEXTAFTERF],[1],[libm includes nextafterf])]) AC_CHECK_LIB([m],[powf],[AC_DEFINE([HAVE_POWF],[1],[libm includes powf])]) @@ -227,6 +228,8 @@ AC_CHECK_LIB([m],[ynf],[AC_DEFINE([HAVE_ # Fallback in case isfinite is not available. AC_CHECK_LIB([m],[finite],[AC_DEFINE([HAVE_FINITE],[1],[libm includes finite])]) +AC_CHECK_LIB([sunmath],[log10l],[AC_DEFINE([HAVE_LOG10L_IN_LIBSUNMATH],[1],[libsunmath includes log10l])]) +AC_CHECK_LIB([sunmath],[finitel],[AC_DEFINE([HAVE_FINITEL_IN_LIBSUNMATH],[1],[libsunmath includes finitel])]) # Let the user override this AC_ARG_ENABLE(cmath, Index: libgfortran/libgfortran.h =================================================================== RCS file: /cvsroot/gcc/gcc/libgfortran/libgfortran.h,v retrieving revision 1.24 diff -p -u -r1.24 libgfortran.h --- libgfortran/libgfortran.h 30 Apr 2005 20:51:29 -0000 1.24 +++ libgfortran/libgfortran.h 6 Jun 2005 20:54:24 -0000 @@ -197,20 +197,7 @@ isfinite (double x) #define IMAGPART(z) (__imag__(z)) #define COMPLEX_ASSIGN(z_, r_, i_) {__real__(z_) = (r_); __imag__(z_) = (i_);} -typedef int8_t GFC_INTEGER_1; -typedef int16_t GFC_INTEGER_2; -typedef int32_t GFC_INTEGER_4; -typedef int64_t GFC_INTEGER_8; -typedef uint8_t GFC_UINTEGER_1; -typedef uint16_t GFC_UINTEGER_2; -typedef uint32_t GFC_UINTEGER_4; -typedef uint64_t GFC_UINTEGER_8; -typedef GFC_INTEGER_4 GFC_LOGICAL_4; -typedef GFC_INTEGER_8 GFC_LOGICAL_8; -typedef float GFC_REAL_4; -typedef double GFC_REAL_8; -typedef complex float GFC_COMPLEX_4; -typedef complex double GFC_COMPLEX_8; +#include "kinds.h" /* The following two definitions must be consistent with the types used by the compiler. */ @@ -384,10 +371,10 @@ internal_proto(get_args); /* error.c */ -extern char *gfc_itoa (int64_t); +extern char *gfc_itoa (GFC_INTEGER_LARGEST); internal_proto(gfc_itoa); -extern char *xtoa (uint64_t); +extern char *xtoa (GFC_UINTEGER_LARGEST); internal_proto(xtoa); extern void os_error (const char *) __attribute__ ((noreturn)); Index: libgfortran/io/io.h =================================================================== RCS file: /cvsroot/gcc/gcc/libgfortran/io/io.h,v retrieving revision 1.20 diff -p -u -r1.20 io.h --- libgfortran/io/io.h 15 May 2005 12:49:40 -0000 1.20 +++ libgfortran/io/io.h 6 Jun 2005 20:54:24 -0000 @@ -562,10 +562,10 @@ internal_proto(next_record); /* read.c */ -extern void set_integer (void *, int64_t, int); +extern void set_integer (void *, GFC_INTEGER_LARGEST, int); internal_proto(set_integer); -extern uint64_t max_value (int, int); +extern GFC_UINTEGER_LARGEST max_value (int, int); internal_proto(max_value); extern int convert_real (void *, const char *, int); Index: libgfortran/io/list_read.c =================================================================== RCS file: /cvsroot/gcc/gcc/libgfortran/io/list_read.c,v retrieving revision 1.22 diff -p -u -r1.22 list_read.c --- libgfortran/io/list_read.c 17 May 2005 16:54:51 -0000 1.22 +++ libgfortran/io/list_read.c 6 Jun 2005 20:54:24 -0000 @@ -344,7 +344,7 @@ convert_integer (int length, int negativ { char c, *buffer, message[100]; int m; - int64_t v, max, max10; + GFC_INTEGER_LARGEST v, max, max10; buffer = saved_string; v = 0; Index: libgfortran/io/read.c =================================================================== RCS file: /cvsroot/gcc/gcc/libgfortran/io/read.c,v retrieving revision 1.9 diff -p -u -r1.9 read.c --- libgfortran/io/read.c 10 May 2005 08:34:58 -0000 1.9 +++ libgfortran/io/read.c 6 Jun 2005 20:54:24 -0000 @@ -43,21 +43,26 @@ Boston, MA 02111-1307, USA. */ * actually place the value into memory. */ void -set_integer (void *dest, int64_t value, int length) +set_integer (void *dest, GFC_INTEGER_LARGEST value, int length) { switch (length) { +#ifdef HAVE_GFC_INTEGER_16 + case 16: + *((GFC_INTEGER_16 *) dest) = value; + break; +#endif case 8: - *((int64_t *) dest) = value; + *((GFC_INTEGER_8 *) dest) = value; break; case 4: - *((int32_t *) dest) = value; + *((GFC_INTEGER_4 *) dest) = value; break; case 2: - *((int16_t *) dest) = value; + *((GFC_INTEGER_2 *) dest) = value; break; case 1: - *((int8_t *) dest) = value; + *((GFC_INTEGER_1 *) dest) = value; break; default: internal_error ("Bad integer kind"); @@ -68,13 +73,24 @@ set_integer (void *dest, int64_t value, /* max_value()-- Given a length (kind), return the maximum signed or * unsigned value */ -uint64_t +GFC_UINTEGER_LARGEST max_value (int length, int signed_flag) { - uint64_t value; + GFC_UINTEGER_LARGEST value; + int n; switch (length) { +#if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10 + case 16: + case 10: + value = 1; + for (n = 1; n < 4 * length; n++) + value = (value << 2) + 3; + if (! signed_flag) + value = 2*value+1; + break; +#endif case 8: value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff; break; @@ -108,16 +124,26 @@ convert_real (void *dest, const char *bu switch (length) { case 4: - *((float *) dest) = + *((GFC_REAL_4 *) dest) = #if defined(HAVE_STRTOF) strtof (buffer, NULL); #else - (float) strtod (buffer, NULL); + (GFC_REAL_4) strtod (buffer, NULL); #endif break; case 8: - *((double *) dest) = strtod (buffer, NULL); + *((GFC_REAL_8 *) dest) = strtod (buffer, NULL); + break; +#if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD) + case 10: + *((GFC_REAL_10 *) dest) = strtold (buffer, NULL); + break; +#endif +#if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD) + case 16: + *((GFC_REAL_16 *) dest) = strtold (buffer, NULL); break; +#endif default: internal_error ("Unsupported real kind during IO"); } @@ -164,11 +190,11 @@ read_l (fnode * f, char *dest, int lengt { case 't': case 'T': - set_integer (dest, 1, length); + set_integer (dest, (GFC_INTEGER_LARGEST) 1, length); break; case 'f': case 'F': - set_integer (dest, 0, length); + set_integer (dest, (GFC_INTEGER_LARGEST) 0, length); break; default: bad: @@ -263,8 +289,9 @@ next_char (char **p, int *w) void read_decimal (fnode * f, char *dest, int length) { - unsigned value, maxv, maxv_10; - int v, w, negative; + GFC_UINTEGER_LARGEST value, maxv, maxv_10; + GFC_INTEGER_LARGEST v; + int w, negative; char c, *p; w = f->u.w; @@ -275,7 +302,7 @@ read_decimal (fnode * f, char *dest, int p = eat_leading_spaces (&w, p); if (w == 0) { - set_integer (dest, 0, length); + set_integer (dest, (GFC_INTEGER_LARGEST) 0, length); return; } @@ -324,7 +351,7 @@ read_decimal (fnode * f, char *dest, int value += c; } - v = (signed int) value; + v = value; if (negative) v = -v; @@ -350,8 +377,9 @@ read_decimal (fnode * f, char *dest, int void read_radix (fnode * f, char *dest, int length, int radix) { - unsigned value, maxv, maxv_r; - int v, w, negative; + GFC_UINTEGER_LARGEST value, maxv, maxv_r; + GFC_INTEGER_LARGEST v; + int w, negative; char c, *p; w = f->u.w; @@ -362,7 +390,7 @@ read_radix (fnode * f, char *dest, int l p = eat_leading_spaces (&w, p); if (w == 0) { - set_integer (dest, 0, length); + set_integer (dest, (GFC_INTEGER_LARGEST) 0, length); return; } @@ -460,7 +488,7 @@ read_radix (fnode * f, char *dest, int l value += c; } - v = (signed int) value; + v = value; if (negative) v = -v; @@ -508,12 +536,24 @@ read_f (fnode * f, char *dest, int lengt switch (length) { case 4: - *((float *) dest) = 0.0f; + *((GFC_REAL_4 *) dest) = 0.0f; break; case 8: - *((double *) dest) = 0.0; + *((GFC_REAL_8 *) dest) = 0.0; + break; + +#ifdef HAVE_GFC_REAL_10 + case 10: + *((GFC_REAL_10 *) dest) = 0.0; + break; +#endif + +#ifdef HAVE_GFC_REAL_16 + case 16: + *((GFC_REAL_16 *) dest) = 0.0; break; +#endif default: internal_error ("Unsupported real kind during IO"); Index: libgfortran/io/write.c =================================================================== RCS file: /cvsroot/gcc/gcc/libgfortran/io/write.c,v retrieving revision 1.38 diff -p -u -r1.38 write.c --- libgfortran/io/write.c 22 May 2005 21:17:42 -0000 1.38 +++ libgfortran/io/write.c 6 Jun 2005 20:54:24 -0000 @@ -37,6 +37,9 @@ Boston, MA 02111-1307, USA. */ #include "libgfortran.h" #include "io.h" +#if HAVE_SUNMATH_H +#include <sunmath.h> +#endif #define star_fill(p, n) memset(p, '*', n) @@ -69,10 +72,10 @@ write_a (fnode * f, const char *source, } } -static int64_t +static GFC_INTEGER_LARGEST extract_int (const void *p, int len) { - int64_t i = 0; + GFC_INTEGER_LARGEST i = 0; if (p == NULL) return i; @@ -80,17 +83,22 @@ extract_int (const void *p, int len) switch (len) { case 1: - i = *((const int8_t *) p); + i = *((const GFC_INTEGER_1 *) p); break; case 2: - i = *((const int16_t *) p); + i = *((const GFC_INTEGER_2 *) p); break; case 4: - i = *((const int32_t *) p); + i = *((const GFC_INTEGER_4 *) p); break; case 8: - i = *((const int64_t *) p); + i = *((const GFC_INTEGER_8 *) p); + break; +#ifdef HAVE_GFC_INTEGER_16 + case 16: + i = *((const GFC_INTEGER_16 *) p); break; +#endif default: internal_error ("bad integer kind"); } @@ -98,23 +106,32 @@ extract_int (const void *p, int len) return i; } -static double +static GFC_REAL_LARGEST extract_real (const void *p, int len) { - double i = 0.0; + GFC_REAL_LARGEST i = 0; switch (len) { case 4: - i = *((const float *) p); + i = *((const GFC_REAL_4 *) p); break; case 8: - i = *((const double *) p); + i = *((const GFC_REAL_8 *) p); + break; +#ifdef HAVE_GFC_REAL_10 + case 10: + i = *((const GFC_REAL_10 *) p); break; +#endif +#ifdef HAVE_GFC_REAL_16 + case 16: + i = *((const GFC_REAL_16 *) p); + break; +#endif default: internal_error ("bad real kind"); } return i; - } @@ -148,11 +165,11 @@ calculate_sign (int negative_flag) /* Returns the value of 10**d. */ -static double +static GFC_REAL_LARGEST calculate_exp (int d) { int i; - double r = 1.0; + GFC_REAL_LARGEST r = 1.0; for (i = 0; i< (d >= 0 ? d : -d); i++) r *= 10; @@ -181,13 +198,13 @@ calculate_exp (int d) for Gw.dEe, n' ' means e+2 blanks */ static fnode * -calculate_G_format (fnode *f, double value, int *num_blank) +calculate_G_format (fnode *f, GFC_REAL_LARGEST value, int *num_blank) { int e = f->u.real.e; int d = f->u.real.d; int w = f->u.real.w; fnode *newf; - double m, exp_d; + GFC_REAL_LARGEST m, exp_d; int low, high, mid; int ubound, lbound; @@ -199,8 +216,8 @@ calculate_G_format (fnode *f, double val /* In case of the two data magnitude ranges, generate E editing, Ew.d[Ee]. */ exp_d = calculate_exp (d); - if ((m > 0.0 && m < 0.1 - 0.05 / (double) exp_d) - || (m >= (double) exp_d - 0.5 )) + if ((m > 0.0 && m < 0.1 - 0.05 / (GFC_REAL_LARGEST) exp_d) + || (m >= (GFC_REAL_LARGEST) exp_d - 0.5 )) { newf->format = FMT_E; newf->u.real.w = w; @@ -219,7 +236,7 @@ calculate_G_format (fnode *f, double val while (low <= high) { - double temp; + GFC_REAL_LARGEST temp; mid = (low + high) / 2; /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1) */ @@ -271,7 +288,7 @@ calculate_G_format (fnode *f, double val /* Output a real number according to its format which is FMT_G free. */ static void -output_float (fnode *f, double value) +output_float (fnode *f, GFC_REAL_LARGEST value) { /* This must be large enough to accurately hold any value. */ char buffer[32]; @@ -296,7 +313,7 @@ output_float (fnode *f, double value) int nblanks; int i; sign_t sign; - double abslog; + GFC_REAL_LARGEST abslog; ft = f->format; w = f->u.real.w; @@ -321,11 +338,28 @@ output_float (fnode *f, double value) edigits = 2; else { +#if defined (HAVE_GFC_REAL_10) || defined (HAVE_GFC_REAL_16) +# if HAVE_LOG10L || HAVE_LOG10L_IN_LIBSUNMATH + abslog = fabs(log10l (value)); +# else + extern long double __log10l (long double); + abslog = fabs(__log10l (value)); +# endif +#else abslog = fabs(log10 (value)); +#endif if (abslog < 100) edigits = 2; else +#if defined (HAVE_GFC_REAL_10) || defined (HAVE_GFC_REAL_16) +# if HAVE_LOG10L || HAVE_LOG10L_IN_LIBSUNMATH + edigits = 1 + (int) log10l (abslog); +# else + edigits = 1 + (int) __log10l (abslog); +# endif +#else edigits = 1 + (int) log10 (abslog); +#endif } if (ft == FMT_F || ft == FMT_EN @@ -346,7 +380,24 @@ output_float (fnode *f, double value) ndigits = 27 - edigits; } - sprintf (buffer, "%+-#31.*e", ndigits - 1, value); + /* # The result will always contain a decimal point, even if no + * digits follow it + * + * - The converted value is to be left adjusted on the field boundary + * + * + A sign (+ or -) always be placed before a number + * + * 31 minimum field width + * + * * (ndigits-1) is used as the precision + * + * e format: [-]d.ddde±dd where there is one digit before the + * decimal-point character and the number of digits after it is + * equal to the precision. The exponent always contains at least two + * digits; if the value is zero, the exponent is 00. + */ + sprintf (buffer, "%+-#31.*" GFC_REAL_LARGEST_FORMAT "e", + ndigits - 1, value); /* Check the resulting string has punctuation in the correct places. */ if (buffer[2] != '.' || buffer[ndigits + 2] != 'e') @@ -673,7 +724,7 @@ void write_l (fnode * f, char *source, int len) { char *p; - int64_t n; + GFC_INTEGER_LARGEST n; p = write_block (f->u.w); if (p == NULL) @@ -689,7 +740,7 @@ write_l (fnode * f, char *source, int le static void write_float (fnode *f, const char *source, int len) { - double n; + GFC_REAL_LARGEST n; int nb =0, res, save_scale_factor; char * p, fin; fnode *f2 = NULL; @@ -698,7 +749,11 @@ write_float (fnode *f, const char *sourc if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z) { +#if (HAVE_GFC_REAL_10 || HAVE_GFC_REAL_16) && HAVE_FINITEL + res = finitel (n); +#else res = isfinite (n); +#endif if (res == 0) { nb = f->u.real.w; @@ -756,10 +811,11 @@ write_float (fnode *f, const char *sourc static void -write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t)) +write_int (fnode *f, const char *source, int len, + char *(*conv) (GFC_UINTEGER_LARGEST)) { - uint32_t ns =0; - uint64_t n = 0; +//FXC uint32_t ns =0; + GFC_UINTEGER_LARGEST n = 0; int w, m, digits, nzero, nblank; char *p, *q; @@ -784,12 +840,12 @@ write_int (fnode *f, const char *source, } - if (len < 8) - { - ns = n; - q = conv (ns); - } - else +//FXC if (len < 8) +// { +// ns = n; +// q = conv (ns); +// } +// else q = conv (n); digits = strlen (q); @@ -842,9 +898,10 @@ write_int (fnode *f, const char *source, } static void -write_decimal (fnode *f, const char *source, int len, char *(*conv) (int64_t)) +write_decimal (fnode *f, const char *source, int len, + char *(*conv) (GFC_INTEGER_LARGEST)) { - int64_t n = 0; + GFC_INTEGER_LARGEST n = 0; int w, m, digits, nsign, nzero, nblank; char *p, *q; sign_t sign; @@ -930,7 +987,7 @@ write_decimal (fnode *f, const char *sou /* Convert unsigned octal to ascii. */ static char * -otoa (uint64_t n) +otoa (GFC_UINTEGER_LARGEST n) { char *p; @@ -958,7 +1015,7 @@ otoa (uint64_t n) /* Convert unsigned binary to ascii. */ static char * -btoa (uint64_t n) +btoa (GFC_UINTEGER_LARGEST n) { char *p; Index: libgfortran/runtime/error.c =================================================================== RCS file: /cvsroot/gcc/gcc/libgfortran/runtime/error.c,v retrieving revision 1.9 diff -p -u -r1.9 error.c --- libgfortran/runtime/error.c 12 Jan 2005 21:27:31 -0000 1.9 +++ libgfortran/runtime/error.c 6 Jun 2005 20:54:25 -0000 @@ -69,11 +69,11 @@ static char buffer[32]; /* buffer for i /* Returns a pointer to a static buffer. */ char * -gfc_itoa (int64_t n) +gfc_itoa (GFC_INTEGER_LARGEST n) { int negative; char *p; - uint64_t t; + GFC_UINTEGER_LARGEST t; if (n == 0) { @@ -109,7 +109,7 @@ gfc_itoa (int64_t n) * static buffer. */ char * -xtoa (uint64_t n) +xtoa (GFC_UINTEGER_LARGEST n) { int digit; char *p; Index: gcc/testsuite/lib/target-supports.exp =================================================================== RCS file: /cvsroot/gcc/gcc/gcc/testsuite/lib/target-supports.exp,v retrieving revision 1.58 diff -r1.58 target-supports.exp 412a413,488 > # Return 1 if the target supports Fortran real kinds larger than real(8), > # 0 otherwise. Cache the result. > > proc check_effective_target_fortran_large_real { } { > global et_fortran_large_real_saved > global tool > > if [info exists et_fortran_large_real_saved] { > verbose "check_effective_target_fortran_large_real returning saved $et_fortran_large_real_saved" 2 > } else { > set et_fortran_large_real_saved 0 > > # Set up, compile, and execute a test program using large real > # kinds. Include the current process ID in the file names to > # prevent conflicts with invocations for multiple testsuites. > set src real[pid].f90 > set exe real[pid].x > > set f [open $src "w"] > puts $f "integer,parameter :: k = &" > puts $f " selected_real_kind (precision (0.0_8) + 1)" > puts $f "real(kind=k) :: x" > puts $f "end" > close $f > > verbose "check_effective_target_fortran_large_real compiling testfile $src" 2 > set lines [${tool}_target_compile $src $exe executable ""] > file delete $src > > if [string match "" $lines] then { > # No error message, compilation succeeded. > set et_fortran_large_real_saved 1 > } > } > > return $et_fortran_large_real_saved > } > > # Return 1 if the target supports Fortran integer kinds larger than > # integer(8), 0 otherwise. Cache the result. > > proc check_effective_target_fortran_large_int { } { > global et_fortran_large_int_saved > global tool > > if [info exists et_fortran_large_int_saved] { > verbose "check_effective_target_fortran_large_int returning saved $et_fortran_large_int_saved" 2 > } else { > set et_fortran_large_int_saved 0 > > # Set up, compile, and execute a test program using large integer > # kinds. Include the current process ID in the file names to > # prevent conflicts with invocations for multiple testsuites. > set src int[pid].f90 > set exe int[pid].x > > set f [open $src "w"] > puts $f "integer,parameter :: k = &" > puts $f " selected_int_kind (range (0_8) + 1)" > puts $f "integer(kind=k) :: i" > puts $f "end" > close $f > > verbose "check_effective_target_fortran_large_int compiling testfile $src" 2 > set lines [${tool}_target_compile $src $exe executable ""] > file delete $src > > if [string match "" $lines] then { > # No error message, compilation succeeded. > set et_fortran_large_int_saved 1 > } > } > > return $et_fortran_large_int_saved > } >
! { dg-do run } ! { dg-require-effective-target fortran_large_int } module testmod integer,parameter :: k = selected_int_kind (range (0_8) + 1) contains subroutine testoutput (a,b,length,f) integer(kind=k),intent(in) :: a integer(kind=8),intent(in) :: b integer,intent(in) :: length character(len=*),intent(in) :: f character(len=length) :: ca character(len=length) :: cb write (ca,f) a write (cb,f) b if (ca /= cb) call abort end subroutine testoutput subroutine outputstring (a,f,s) integer(kind=k),intent(in) :: a character(len=*),intent(in) :: f character(len=*),intent(in) :: s character(len=len(s)) :: c write (c,f) a if (c /= s) call abort end subroutine outputstring end module testmod ! Testing I/O of large integer kinds (larger than kind=8) program test use testmod implicit none integer(kind=k) :: x character(len=20) :: c1, c2 end program test
! { dg-do run } ! { dg-require-effective-target fortran_large_real } module testmod integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1) contains subroutine testoutput (a,b,length,f) real(kind=k),intent(in) :: a real(kind=8),intent(in) :: b integer,intent(in) :: length character(len=*),intent(in) :: f character(len=length) :: ca character(len=length) :: cb write (ca,f) a write (cb,f) b if (ca /= cb) call abort end subroutine testoutput subroutine outputstring (a,f,s) real(kind=k),intent(in) :: a character(len=*),intent(in) :: f character(len=*),intent(in) :: s character(len=len(s)) :: c write (c,f) a if (c /= s) call abort end subroutine outputstring end module testmod ! Testing I/O of large real kinds (larger than kind=8) program test use testmod implicit none real(kind=k) :: x character(len=20) :: c1, c2 call testoutput (0.0_k,0.0_8,40,'(F40.35)') call testoutput (1.0_k,1.0_8,40,'(F40.35)') call testoutput (0.1_k,0.1_8,15,'(F15.10)') call testoutput (1e10_k,1e10_8,15,'(F15.10)') call testoutput (7.51e100_k,7.51e100_8,15,'(F15.10)') call testoutput (1e-10_k,1e-10_8,15,'(F15.10)') call testoutput (7.51e-100_k,7.51e-100_8,15,'(F15.10)') call testoutput (-1.0_k,-1.0_8,40,'(F40.35)') call testoutput (-0.1_k,-0.1_8,15,'(F15.10)') call testoutput (-1e10_k,-1e10_8,15,'(F15.10)') call testoutput (-7.51e100_k,-7.51e100_8,15,'(F15.10)') call testoutput (-1e-10_k,-1e-10_8,15,'(F15.10)') call testoutput (-7.51e-100_k,-7.51e-100_8,15,'(F15.10)') x = huge(x) call outputstring (2*x,'(F20.15)',' +Infinity') call outputstring (-2*x,'(F20.15)',' -Infinity') write (c1,'(G20.10E5)') x write (c2,'(G20.10E5)') -x if (c2(1:1) /= '-') call abort c2(1:1) = ' ' if (c1 /= c2) call abort x = tiny(x) call outputstring (x,'(F20.15)',' 0.000000000000000') call outputstring (-x,'(F20.15)',' 0.000000000000000') write (c1,'(G20.10E5)') x write (c2,'(G20.10E5)') -x if (c2(1:1) /= '-') call abort c2(1:1) = ' ' if (c1 /= c2) call abort end program test
Attachment:
mk-kinds-h.sh
Description: Bourne shell script
2005-06-06 Francois-Xavier Coudert <coudert@clipper.ens.fr> * Makefile.am: Use mk-kinds-h.sh to generate header kinds.h with all Fortran kinds available. * configure.ac: Check for sunmath.h. Check for strtold, log10l, and finitel. * Makefile.in: Regenerate. * aclocal.m4: Regenerate. * configure: Regenerate. * config.h.in: Regenerate. * libgfortran.h: Use generated kinds.h to define GFC_INTEGER_*, GFC_UINTEGER_*, GFC_LOGICAL_*, GFC_REAL_*, GFC_COMPLEX_*. Update prototypes for gfc_itoa and xtoa. * io/io.h: Update prototypes for set_integer and max_value. * io/list_read.c (convert_integer): Use new GFC_(INTEGER|REAL)_LARGEST type. * io/read.c (set_integer): Likewise. (max_value): Likewise. (convert_real): Likewise. (real_l): Likewise. (next_char): Likewise. (read_decimal): Likewise. (read_radix): Likewise. (read_f): Likewise. * io/write.c: Use sunmath.h when available. (extract_int): Use new GFC_INTEGER_LARGEST type. (extract_real): Use new GFC_REAL_LARGEST type. (calculate_exp): Likewise. (calculate_G_format): Likewise. (output_float): Likewise. Use log10l for long double values. Add comment for sprintf format. Use GFC_REAL_LARGEST_FORMAT. (write_l): Use new GFC_INTEGER_LARGEST type. (write_float): Use new GFC_REAL_LARGEST type. Use finitel for long double values when available. (write_int): Remove useless special case for (len < 8). (write_decimal): Use GFC_INTEGER_LARGEST. (otoa): Use GFC_UINTEGER_LARGEST as argument. (btoa): Use GFC_UINTEGER_LARGEST as argument. * runtime/error.c (gfc_itoa): Use GFC_INTEGER_LARGEST as argument. (xtoa): Use GFC_UINTEGER_LARGEST as argument. 2005-06-06 Francois-Xavier Coudert <coudert@clipper.ens.fr> * lib/target-supports.exp: Add check_effective_target_fortran_large_real and check_effective_target_fortran_large_int to check for corresponding effective targets.
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |