re PR libfortran/35667 (HP-UX 10 has broken strtod)

	PR fortran/35667
	* io/io.h (convert_infnan): Declare.
	* io/read.c (convert_infnan): New.
	(read_f): Use convert_infnan to convert INFs and NANs.
	* list_read.c (parse_real, read_real): Likewise.

From-SVN: r171182

4 files changed, 101 insertions, 4 deletions

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 70cf85b..1f9da0a 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,11 @@
+2011-03-19  John David Anglin  <dave.anglin@nrc-cnrc.gc.ca>
+
+	PR fortran/35667
+	* io/io.h (convert_infnan): Declare.
+	* io/read.c (convert_infnan): New.
+	(read_f): Use convert_infnan to convert INFs and NANs.
+	* list_read.c (parse_real, read_real): Likewise.
+
 2011-03-19  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
 	PR libfortran/47439
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index ebe7f7c..b48582d 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -674,6 +674,9 @@ internal_proto(max_value);
 extern int convert_real (st_parameter_dt *, void *, const char *, int);
 internal_proto(convert_real);
 
+extern int convert_infnan (st_parameter_dt *, void *, const char *, int);
+internal_proto(convert_infnan);
+
 extern void read_a (st_parameter_dt *, const fnode *, char *, int);
 internal_proto(read_a);
 
diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index ea23232..6e1cb69 100644
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -1215,6 +1215,15 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
 
   return m;
 
+ done_infnan:
+  unget_char (dtp, c);
+  push_char (dtp, '\0');
+
+  m = convert_infnan (dtp, buffer, dtp->u.p.saved_string, length);
+  free_saved (dtp);
+
+  return m;
+
  inf_nan:
   /* Match INF and Infinity.  */
   if ((c == 'i' || c == 'I')
@@ -1235,7 +1244,7 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
 	     push_char (dtp, 'i');
 	     push_char (dtp, 'n');
 	     push_char (dtp, 'f');
-	     goto done;
+	     goto done_infnan;
 	  }
     } /* Match NaN.  */
   else if (((c = next_char (dtp)) == 'a' || c == 'A')
@@ -1259,7 +1268,7 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
 	  if (is_separator (c))
 	    unget_char (dtp, c);
 	}
-      goto done;
+      goto done_infnan;
     }
 
  bad:
@@ -1718,7 +1727,15 @@ read_real (st_parameter_dt *dtp, void * dest, int length)
     }
 
   free_line (dtp);
-  goto done;
+  unget_char (dtp, c);
+  eat_separator (dtp);
+  push_char (dtp, '\0');
+  if (convert_infnan (dtp, dest, dtp->u.p.saved_string, length))
+    return;
+
+  free_saved (dtp);
+  dtp->u.p.saved_type = BT_REAL;
+  return;
 
  unwind:
   if (dtp->u.p.namelist_mode)
diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c
index 50b1b40..d8d2a81 100644
--- a/libgfortran/io/read.c
+++ b/libgfortran/io/read.c
@@ -189,6 +189,75 @@ convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
   return 0;
 }
 
+/* convert_infnan()-- Convert character INF/NAN representation to the
+   machine number.  Note: many architectures (e.g. IA-64, HP-PA) require
+   that the storage pointed to by the dest argument is properly aligned
+   for the type in question.  */
+
+int
+convert_infnan (st_parameter_dt *dtp, void *dest, const char *buffer,
+	        int length)
+{
+  const char *s = buffer;
+  int is_inf, plus = 1;
+
+  if (*s == '+')
+    s++;
+  else if (*s == '-')
+    {
+      s++;
+      plus = 0;
+    }
+
+  is_inf = *s == 'i';
+
+  switch (length)
+    {
+    case 4:
+      if (is_inf)
+	*((GFC_REAL_4*) dest) = plus ? __builtin_inff () : -__builtin_inff ();
+      else
+	*((GFC_REAL_4*) dest) = plus ? __builtin_nanf ("") : -__builtin_nanf ("");
+      break;
+
+    case 8:
+      if (is_inf)
+	*((GFC_REAL_8*) dest) = plus ? __builtin_inf () : -__builtin_inf ();
+      else
+	*((GFC_REAL_8*) dest) = plus ? __builtin_nan ("") : -__builtin_nan ("");
+      break;
+
+#if defined(HAVE_GFC_REAL_10)
+    case 10:
+      if (is_inf)
+	*((GFC_REAL_10*) dest) = plus ? __builtin_infl () : -__builtin_infl ();
+      else
+	*((GFC_REAL_10*) dest) = plus ? __builtin_nanl ("") : -__builtin_nanl ("");
+      break;
+#endif
+
+#if defined(HAVE_GFC_REAL_16)
+# if defined(GFC_REAL_16_IS_FLOAT128)
+    case 16:
+      *((GFC_REAL_16*) dest) = __qmath_(strtoflt128) (buffer, NULL);
+      break;
+# else
+    case 16:
+      if (is_inf)
+	*((GFC_REAL_16*) dest) = plus ? __builtin_infl () : -__builtin_infl ();
+      else
+	*((GFC_REAL_16*) dest) = plus ? __builtin_nanl ("") : -__builtin_nanl ("");
+      break;
+# endif
+#endif
+
+    default:
+      internal_error (&dtp->common, "Unsupported real kind during IO");
+    }
+
+  return 0;
+}
+
 
 /* read_l()-- Read a logical value */
 
@@ -896,7 +965,7 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
       else if (strcmp (save, "nan") != 0)
 	goto bad_float;
 
-      convert_real (dtp, dest, buffer, length);
+      convert_infnan (dtp, dest, buffer, length);
       return;
     }