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]

Re: [gfortran] I/O of large integer and real kinds, round 2


Built, tested and regtested on:
   - i686-linux, which has real(10)
   - i386-freebsd
   - sparc-solaris, which has real(16)
   - x86_64-linux, which has real(10) and integer(16)
   - alpha-linux, which has integer(16)

OK for mainline? (and should it be backported to 4.0, too?)

Tobias told me I sent a barely readable patch with no context around my changes. Sorry for the inconvenience (and then, how many times a week do I say "sorry" on this list? it's high time to upgrade my brain).


FX
! { 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>

	* intrinsics/c99_functions.c (log10l): New log10l function for
	systems where this is not available.
	* c99_protos.h: Prototype for log10l function.
	* 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 (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.
	(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.
	* Makefile.am: Use mk-kinds-h.sh to generate header kinds.h
	with all Fortran kinds available.
	* configure.ac: Check for strtold and log10l.
	* Makefile.in: Regenerate.
	* aclocal.m4: Regenerate.
	* configure: Regenerate.
	* config.h.in: Regenerate.


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.


2005-06-06  Francois-Xavier Coudert  <coudert@clipper.ens.fr>

	* large_integer_kind_1.f90: New test.
	* large_real_kind_1.f90: New test.
Index: gcc/testsuite/lib/target-supports.exp
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/testsuite/lib/target-supports.exp,v
retrieving revision 1.61
diff -p -u -r1.61 target-supports.exp
--- gcc/testsuite/lib/target-supports.exp	7 Jun 2005 19:27:01 -0000	1.61
+++ gcc/testsuite/lib/target-supports.exp	8 Jun 2005 22:40:19 -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: /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	8 Jun 2005 22:40:33 -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/c99_protos.h
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/c99_protos.h,v
retrieving revision 1.3
diff -p -u -r1.3 c99_protos.h
--- libgfortran/c99_protos.h	21 May 2005 06:44:48 -0000	1.3
+++ libgfortran/c99_protos.h	8 Jun 2005 22:40:33 -0000
@@ -137,5 +137,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: /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	8 Jun 2005 22:40:34 -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: /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	8 Jun 2005 22:40:34 -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/intrinsics/c99_functions.c
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/intrinsics/c99_functions.c,v
retrieving revision 1.11
diff -p -u -r1.11 c99_functions.c
--- libgfortran/intrinsics/c99_functions.c	21 May 2005 06:44:50 -0000	1.11
+++ libgfortran/intrinsics/c99_functions.c	8 Jun 2005 22:40:34 -0000
@@ -363,3 +363,47 @@ 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)
+{
+  long double result;
+  
+  if (x <= 0)
+    return ((long double) log10 ((double) x));
+
+  result = 0;
+  if (x > 1)
+    {
+      while (x > 1e100L)
+      {
+        result += 100;
+        x /= 1e100L;
+      }
+      while (x > 1e10L)
+      {
+        result += 10;
+        x /= 1e10L;
+      }
+    }
+  else
+    {
+      while (x < 1e-100L)
+      {
+        result -= 100;
+        x *= 1e100L;
+      }
+      while (x < 1e-10L)
+      {
+        result -= 10;
+        x *= 1e10L;
+      }
+    }
+
+  result += log10 ((double) x);
+  return result;
+}
+#endif
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	8 Jun 2005 22:40:35 -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	8 Jun 2005 22:40:35 -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	8 Jun 2005 22:40:35 -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/transfer.c
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/io/transfer.c,v
retrieving revision 1.42
diff -p -u -r1.42 transfer.c
--- libgfortran/io/transfer.c	29 May 2005 12:22:49 -0000	1.42
+++ libgfortran/io/transfer.c	8 Jun 2005 22:40:35 -0000
@@ -160,7 +160,6 @@ read_sf (int *length)
       return base;
     }
 
-  current_unit->bytes_left = options.default_recl;
   readlen = 1;
   n = 0;
 
@@ -214,6 +213,7 @@ read_sf (int *length)
       sf_seen_eor = 0;
     }
   while (n < *length);
+  current_unit->bytes_left -= *length;
 
   if (ioparm.size != NULL)
     *ioparm.size += *length;
@@ -675,22 +675,19 @@ formatted_transfer (bt type, void *p, in
 
         case FMT_TL:
         case FMT_T:
-           if (f->format==FMT_TL)
-             {
-                pos = f->u.n ;
-                pos= current_unit->recl - current_unit->bytes_left - pos;
-             }
-           else // FMT==T
+           if (f->format == FMT_TL)
+             pos = current_unit->recl - current_unit->bytes_left - f->u.n;
+           else /* FMT_T */
              {
-                consume_data_flag = 0 ;
-                pos = f->u.n - 1;
+               consume_data_flag = 0;
+               pos = f->u.n - 1;
              }
 
            if (pos < 0 || pos >= current_unit->recl )
-           {
-             generate_error (ERROR_EOR, "T Or TL edit position error");
-             break ;
-            }
+             {
+               generate_error (ERROR_EOR, "T Or TL edit position error");
+               break ;
+             }
             m = pos - (current_unit->recl - current_unit->bytes_left);
 
             if (m == 0)
@@ -707,6 +704,7 @@ formatted_transfer (bt type, void *p, in
             if (m < 0)
              {
                move_pos_offset (current_unit->s,m);
+	       current_unit->bytes_left -= m;
              }
 
 	  break;
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	8 Jun 2005 22:40:35 -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: /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	8 Jun 2005 22:40:35 -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 Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]