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] |
> Fine. I'll come up with a final version of the patch, which I will > regtest on all platforms available to me (sparc-solaris, i686-linux, > i386-freebsd, x86_64-linux). Will you make a last regtest on > amd64-freebsd? Attached patch built, tested and regtested on i686-linux, amd64-linux and alpha-linux. I did a hack to force the use of the provided log10l instead of the system's one in amd64-linux, and it did regtest fine too. Please test on amd64-freebsd if you think necessary. I'm waiting for your approval to commit. Thanks again, FX
Index: gcc/testsuite/gfortran.dg/large_integer_kind_1.f90 =================================================================== RCS file: gcc/testsuite/gfortran.dg/large_integer_kind_1.f90 diff -N gcc/testsuite/gfortran.dg/large_integer_kind_1.f90 --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ gcc/testsuite/gfortran.dg/large_integer_kind_1.f90 23 Jun 2005 09:04:27 -0000 @@ -0,0 +1,42 @@ +! { 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 Index: gcc/testsuite/gfortran.dg/large_real_kind_1.f90 =================================================================== RCS file: gcc/testsuite/gfortran.dg/large_real_kind_1.f90 diff -N gcc/testsuite/gfortran.dg/large_real_kind_1.f90 --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ gcc/testsuite/gfortran.dg/large_real_kind_1.f90 23 Jun 2005 09:04:27 -0000 @@ -0,0 +1,77 @@ +! { 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 Index: gcc/testsuite/lib/target-supports.exp =================================================================== RCS file: /cvs/gcc/gcc/gcc/testsuite/lib/target-supports.exp,v retrieving revision 1.63 diff -u -3 -p -r1.63 target-supports.exp --- gcc/testsuite/lib/target-supports.exp 21 Jun 2005 09:02:00 -0000 1.63 +++ gcc/testsuite/lib/target-supports.exp 23 Jun 2005 09:04:28 -0000 @@ -410,6 +410,82 @@ proc check_named_sections_available { } return $answer } +# 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 +} + # Return 1 if the target supports executing AltiVec instructions, 0 # otherwise. Cache the result. Index: libgfortran/Makefile.am =================================================================== RCS file: /cvs/gcc/gcc/libgfortran/Makefile.am,v retrieving revision 1.36 diff -u -3 -p -r1.36 Makefile.am --- libgfortran/Makefile.am 11 Jun 2005 19:39:09 -0000 1.36 +++ libgfortran/Makefile.am 23 Jun 2005 09:04:28 -0000 @@ -299,7 +299,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. @@ -419,6 +419,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/c99_protos.h =================================================================== RCS file: /cvs/gcc/gcc/libgfortran/c99_protos.h,v retrieving revision 1.4 diff -u -3 -p -r1.4 c99_protos.h --- libgfortran/c99_protos.h 15 Jun 2005 08:40:31 -0000 1.4 +++ libgfortran/c99_protos.h 23 Jun 2005 09:04:28 -0000 @@ -141,5 +141,9 @@ extern double round(double); extern float roundf(float); #endif +#ifndef HAVE_LOG10L +extern long double log10l(long double); +#endif + #endif /* C99_PROTOS_H */ Index: libgfortran/configure.ac =================================================================== RCS file: /cvs/gcc/gcc/libgfortran/configure.ac,v retrieving revision 1.28 diff -u -3 -p -r1.28 configure.ac --- libgfortran/configure.ac 15 Jun 2005 08:40:33 -0000 1.28 +++ libgfortran/configure.ac 23 Jun 2005 09:04:28 -0000 @@ -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])]) Index: libgfortran/libgfortran.h =================================================================== RCS file: /cvs/gcc/gcc/libgfortran/libgfortran.h,v retrieving revision 1.25 diff -u -3 -p -r1.25 libgfortran.h --- libgfortran/libgfortran.h 11 Jun 2005 19:39:09 -0000 1.25 +++ libgfortran/libgfortran.h 23 Jun 2005 09:04:28 -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/mk-kinds-h.sh =================================================================== RCS file: libgfortran/mk-kinds-h.sh diff -N libgfortran/mk-kinds-h.sh --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ libgfortran/mk-kinds-h.sh 23 Jun 2005 09:04:28 -0000 @@ -0,0 +1,65 @@ +#!/bin/sh + +compile="$1" + +# Possible types must be listed in ascending order +possible_integer_kinds="1 2 4 8 16" +possible_real_kinds="4 8 10 16" + + +largest="" +for k in $possible_integer_kinds; do + echo " integer (kind=$k) :: i" > tmp$$.f90 + echo " end" >> tmp$$.f90 + if $compile -c tmp$$.f90 > /dev/null 2>&1; then + s=`expr 8 \* $k` + largest="$k" + + if [ $s -eq 128 ]; then + prefix="__" + else + prefix="" + fi + + echo "typedef ${prefix}int${s}_t GFC_INTEGER_${k};" + echo "typedef ${prefix}uint${s}_t GFC_UINTEGER_${k};" + echo "typedef GFC_INTEGER_${k} GFC_LOGICAL_${k};" + echo "#define HAVE_GFC_INTEGER_${k}" + fi + rm -f tmp$$.* +done + +echo "#define GFC_INTEGER_LARGEST GFC_INTEGER_${largest}" +echo "#define GFC_UINTEGER_LARGEST GFC_UINTEGER_${largest}" +echo "" + + +largest_ctype="" +for k in $possible_real_kinds; do + echo " real (kind=$k) :: x" > tmp$$.f90 + echo " end" >> tmp$$.f90 + if $compile -c tmp$$.f90 > /dev/null 2>&1; then + case $k in + 4) ctype="float" ;; + 8) ctype="double" ;; + 10) ctype="long double" ;; + 16) ctype="long double" ;; + *) echo "$0: Unknown type" >&2 ; exit 1 ;; + esac + largest_ctype="$ctype" + echo "typedef ${ctype} GFC_REAL_${k};" + echo "typedef complex ${ctype} GFC_COMPLEX_${k};" + echo "#define HAVE_GFC_REAL_${k}" + fi + rm -f tmp$$.* +done + +case $largest_ctype in + float) echo "#define GFC_REAL_LARGEST_FORMAT \"\"" ;; + double) echo "#define GFC_REAL_LARGEST_FORMAT \"l\"" ;; + "long double") echo "#define GFC_REAL_LARGEST_FORMAT \"L\"" ;; + *) echo "$0: Unknown type" >&2 ; exit 1 ;; +esac +echo "#define GFC_REAL_LARGEST $largest_ctype" + +exit 0 Index: libgfortran/intrinsics/c99_functions.c =================================================================== RCS file: /cvs/gcc/gcc/libgfortran/intrinsics/c99_functions.c,v retrieving revision 1.12 diff -u -3 -p -r1.12 c99_functions.c --- libgfortran/intrinsics/c99_functions.c 15 Jun 2005 08:40:35 -0000 1.12 +++ libgfortran/intrinsics/c99_functions.c 23 Jun 2005 09:04:28 -0000 @@ -371,3 +371,41 @@ roundf(float x) } } #endif + +#ifndef HAVE_LOG10L +/* log10 function for long double variables. The version provided here + reduces the argument until it fits into a double, then use log10. */ +long double +log10l(long double x) +{ +#if LDBL_MAX_EXP > DBL_MAX_EXP + if (x > DBL_MAX) + { + double val; + int p2_result = 0; + if (x > 0x1p16383L) { p2_result += 16383; x /= 0x1p16383L; } + if (x > 0x1p8191L) { p2_result += 8191; x /= 0x1p8191L; } + if (x > 0x1p4095L) { p2_result += 4095; x /= 0x1p4095L; } + if (x > 0x1p2047L) { p2_result += 2047; x /= 0x1p2047L; } + if (x > 0x1p1023L) { p2_result += 1023; x /= 0x1p1023L; } + val = log10 ((double) x); + return (val + p2_result * .30102999566398119521373889472449302L); + } +#endif +#if LDBL_MIN_EXP < DBL_MIN_EXP + if (x < DBL_MIN) + { + double val; + int p2_result = 0; + if (x < 0x1p-16380L) { p2_result += 16380; x /= 0x1p-16380L; } + if (x < 0x1p-8189L) { p2_result += 8189; x /= 0x1p-8189L; } + if (x < 0x1p-4093L) { p2_result += 4093; x /= 0x1p-4093L; } + if (x < 0x1p-2045L) { p2_result += 2045; x /= 0x1p-2045L; } + if (x < 0x1p-1021L) { p2_result += 1021; x /= 0x1p-1021L; } + val = fabs(log10 ((double) x)); + return (- val - p2_result * .30102999566398119521373889472449302L); + } +#endif + return log10 (x); +} +#endif Index: libgfortran/io/io.h =================================================================== RCS file: /cvs/gcc/gcc/libgfortran/io/io.h,v retrieving revision 1.20 diff -u -3 -p -r1.20 io.h --- libgfortran/io/io.h 15 May 2005 12:49:40 -0000 1.20 +++ libgfortran/io/io.h 23 Jun 2005 09:04:28 -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: /cvs/gcc/gcc/libgfortran/io/list_read.c,v retrieving revision 1.23 diff -u -3 -p -r1.23 list_read.c --- libgfortran/io/list_read.c 16 Jun 2005 22:50:47 -0000 1.23 +++ libgfortran/io/list_read.c 23 Jun 2005 09:04:28 -0000 @@ -339,7 +339,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: /cvs/gcc/gcc/libgfortran/io/read.c,v retrieving revision 1.11 diff -u -3 -p -r1.11 read.c --- libgfortran/io/read.c 17 Jun 2005 16:20:29 -0000 1.11 +++ libgfortran/io/read.c 23 Jun 2005 09:04:28 -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; @@ -594,12 +622,24 @@ read_f (fnode * f, char *dest, int lengt switch (length) { case 4: - *((float *) dest) = 0.0f; + *((GFC_REAL_4 *) dest) = 0; break; case 8: - *((double *) dest) = 0.0; + *((GFC_REAL_8 *) dest) = 0; + break; + +#ifdef HAVE_GFC_REAL_10 + case 10: + *((GFC_REAL_10 *) dest) = 0; break; +#endif + +#ifdef HAVE_GFC_REAL_16 + case 16: + *((GFC_REAL_16 *) dest) = 0; + break; +#endif default: internal_error ("Unsupported real kind during IO"); Index: libgfortran/io/write.c =================================================================== RCS file: /cvs/gcc/gcc/libgfortran/io/write.c,v retrieving revision 1.38 diff -u -3 -p -r1.38 write.c --- libgfortran/io/write.c 22 May 2005 21:17:42 -0000 1.38 +++ libgfortran/io/write.c 23 Jun 2005 09:04:32 -0000 @@ -37,7 +37,6 @@ Boston, MA 02111-1307, USA. */ #include "libgfortran.h" #include "io.h" - #define star_fill(p, n) memset(p, '*', n) @@ -69,10 +68,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 +79,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 +102,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 +161,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 +194,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 +212,7 @@ 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 / exp_d) || (m >= exp_d - 0.5 )) { newf->format = FMT_E; newf->u.real.w = w; @@ -219,7 +231,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 +283,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]; @@ -321,11 +333,15 @@ output_float (fnode *f, double value) edigits = 2; else { - abslog = fabs(log10 (value)); +#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16) + abslog = fabs((double) log10l(value)); +#else + abslog = fabs(log10(value)); +#endif if (abslog < 100) edigits = 2; else - edigits = 1 + (int) log10 (abslog); + edigits = 1 + (int) log10(abslog); } if (ft == FMT_F || ft == FMT_EN @@ -346,7 +362,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 +706,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 +722,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 +731,10 @@ write_float (fnode *f, const char *sourc if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z) { - res = isfinite (n); + /* TODO: there are some systems where isfinite is not able to work + with long double variables. We should detect this case and + provide our own version for isfinite. */ + res = isfinite (n); if (res == 0) { nb = f->u.real.w; @@ -756,10 +792,10 @@ 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; + GFC_UINTEGER_LARGEST n = 0; int w, m, digits, nzero, nblank; char *p, *q; @@ -783,15 +819,7 @@ write_int (fnode *f, const char *source, goto done; } - - if (len < 8) - { - ns = n; - q = conv (ns); - } - else - q = conv (n); - + q = conv (n); digits = strlen (q); /* Select a width if none was specified. The idea here is to always @@ -842,9 +870,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 +959,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 +987,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: /cvs/gcc/gcc/libgfortran/runtime/error.c,v retrieving revision 1.9 diff -u -3 -p -r1.9 error.c --- libgfortran/runtime/error.c 12 Jan 2005 21:27:31 -0000 1.9 +++ libgfortran/runtime/error.c 23 Jun 2005 09:04:32 -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;
Attachment:
allkinds.ChangeLog
Description: Binary data
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |