re PR fortran/37498 (Incorrect array value returned - 4.3 ABI Broken)

2008-09-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org

	PR fortran/37498
	* trans-io.c (gfc_build_io_library_fndecls): Bump pad size.
	(build_dt): Set mask bit for IOPARM_dt_f2003.
	* ioparm.def: Add IOPARM_dt_f2003.

2008-09-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org

	PR libfortran/37498
	* file_pos (st_endfile): Clear memory only for libfortran 4.3 private
	area.
	* list_read.c (eat_separator): Only access F2003 I/O parameters if
	IOPARM_DT_HAS_F2003 bit is set. (parse_real): Ditto.
	(read_real): Ditto.
	* read.c (read_a): Likewise. (read_a_char4): Likewise though not
	strictly necessary. (read_f): Likewise.
	* io.h (unit_sign_s): New enumerator to allow duplication of
	st_parameter structures. (IOPARM_DT_HAS_F2003): New mask bit.
	(st_parameter_43): New structure copied from 4.3 version of 
	st_paramater_dt private section. (st_parameter_44): New structure with
	F2003 items added. (st_parameter_dt): Modified to create union of new
	and old structures to allow correct memory setting for 4.3 ABI
	compatibility. Bumped the pad size.
	* transfer.c (read_sf): Do not use F2003 I/O memory areas unless
	IOPARM_DT_HAS_F2003 bit has been set. (read_block_form): Ditto.
	(formatted_transfer_scalar): Ditto. (data_transfer_init): Ditto and
	add comment, fix formatting.
	* write.c (write_default_char4): Likewise though not strictly necessary.
	(write_utf8_char4): Ditto. (write_character): Ditto.
	(write_real_g0): Ditto. (list_formatted_write_scalar): Ditto.
	(nml_write_obj): Ditto. (namelist_write): Ditto.
	* write_float.def (calculate_sign): Eliminate warning by including all
	cases in switch. (output_float): Output only decimal point of F2003 flag
	is not set.

From-SVN: r140576

gcc/fortran/ChangeLog

+2008-09-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org
+
+	PR fortran/37498
+	* trans-io.c (gfc_build_io_library_fndecls): Bump pad size.
+	(build_dt): Set mask bit for IOPARM_dt_f2003.
+	* ioparm.def: Add IOPARM_dt_f2003.
+
 2008-09-22  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/37486

gcc/fortran/ioparm.def

@@ -93,3 +93,4 @@ IOPARM (dt,      pad,		1 << 22, char1)
 IOPARM (dt,      round,		1 << 23, char2)
 IOPARM (dt,      sign,		1 << 24, char1)
 IOPARM (dt,      u,		0,	 pad)
+#define IOPARM_dt_f2003			(1 << 25)

gcc/fortran/trans-io.c

@@ -291,7 +291,7 @@ gfc_build_io_library_fndecls (void)
 			    = build_pointer_type (gfc_intio_type_node);
   types[IOPARM_type_parray] = pchar_type_node;
   types[IOPARM_type_pchar] = pchar_type_node;
-  pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
+  pad_size = 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
   pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
   pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size));
   types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
@@ -1641,7 +1641,7 @@ build_dt (tree function, gfc_code * code)
   tree tmp, var;
   gfc_expr *nmlname;
   gfc_namelist *nml;
-  unsigned int mask = 0;
+  unsigned int mask = IOPARM_dt_f2003;
 
   gfc_start_block (&block);
   gfc_init_block (&post_block);

libgfortran/ChangeLog

+2008-09-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org
+
+	PR libfortran/37498
+	* file_pos (st_endfile): Clear memory only for libfortran 4.3 private
+	area.
+	* list_read.c (eat_separator): Only access F2003 I/O parameters if
+	IOPARM_DT_HAS_F2003 bit is set. (parse_real): Ditto.
+	(read_real): Ditto.
+	* read.c (read_a): Likewise. (read_a_char4): Likewise though not
+	strictly necessary. (read_f): Likewise.
+	* io.h (unit_sign_s): New enumerator to allow duplication of
+	st_parameter structures. (IOPARM_DT_HAS_F2003): New mask bit.
+	(st_parameter_43): New structure copied from 4.3 version of 
+	st_paramater_dt private section. (st_parameter_44): New structure with
+	F2003 items added. (st_parameter_dt): Modified to create union of new
+	and old structures to allow correct memory setting for 4.3 ABI
+	compatibility. Bumped the pad size.
+	* transfer.c (read_sf): Do not use F2003 I/O memory areas unless
+	IOPARM_DT_HAS_F2003 bit has been set. (read_block_form): Ditto.
+	(formatted_transfer_scalar): Ditto. (data_transfer_init): Ditto and
+	add comment, fix formatting.
+	* write.c (write_default_char4): Likewise though not strictly necessary.
+	(write_utf8_char4): Ditto. (write_character): Ditto.
+	(write_real_g0): Ditto. (list_formatted_write_scalar): Ditto.
+	(nml_write_obj): Ditto. (namelist_write): Ditto.
+	* write_float.def (calculate_sign): Eliminate warning by including all
+	cases in switch. (output_float): Output only decimal point of F2003 flag
+	is not set.
+
 2008-09-10  Tobias Burnus  <burnus@net-b.de>
 	    H. J. Lu  <hongjiu.lu@intel.com>
 

libgfortran/io/file_pos.c

@@ -300,7 +300,7 @@ st_endfile (st_parameter_filepos *fpp)
 	{
 	  st_parameter_dt dtp;
 	  dtp.common = fpp->common;
-	  memset (&dtp.u.p, 0, sizeof (dtp.u.p));
+	  memset (&dtp.u.p.transfer, 0, sizeof (dtp.u.q));
 	  dtp.u.p.current_unit = u;
 	  next_record (&dtp, 1);
 	}

libgfortran/io/list_read.c

@@ -324,7 +324,8 @@ eat_separator (st_parameter_dt *dtp)
   switch (c)
     {
     case ',':
-      if (dtp->u.p.decimal_status == DECIMAL_COMMA)
+      if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+	  && dtp->u.p.decimal_status == DECIMAL_COMMA)
 	{
 	  unget_char (dtp, c);
 	  break;
@@ -1116,7 +1117,8 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
       c = next_char (dtp);
     }
 
-  if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+  if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+      && c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
     c = '.';
   
   if (!isdigit (c) && c != '.')
@@ -1134,7 +1136,8 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
   for (;;)
     {
       c = next_char (dtp);
-      if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+      if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+	  && c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
 	c = '.';
       switch (c)
 	{
@@ -1305,9 +1308,17 @@ eol_1:
   else
     unget_char (dtp, c);
 
-  if (next_char (dtp)
-      !=  (dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';'))
-    goto bad_complex;
+  if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+    {
+      if (next_char (dtp)
+	  !=  (dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';'))
+	goto bad_complex;
+    }
+  else
+    {
+      if (next_char (dtp) != ',')
+	goto bad_complex;
+    }
 
 eol_2:
   eat_spaces (dtp);
@@ -1360,7 +1371,8 @@ read_real (st_parameter_dt *dtp, int length)
   seen_dp = 0;
 
   c = next_char (dtp);
-  if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+  if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+      && c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
     c = '.';
   switch (c)
     {
@@ -1397,7 +1409,8 @@ read_real (st_parameter_dt *dtp, int length)
   for (;;)
     {
       c = next_char (dtp);
-      if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+      if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+	  && c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
 	c = '.';
       switch (c)
 	{
@@ -1463,7 +1476,8 @@ read_real (st_parameter_dt *dtp, int length)
       c = next_char (dtp);
     }
 
-  if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+  if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+      && c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
     c = '.';
 
   if (!isdigit (c) && c != '.')
@@ -1488,7 +1502,8 @@ read_real (st_parameter_dt *dtp, int length)
   for (;;)
     {
       c = next_char (dtp);
-      if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+      if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+	  && c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
 	c = '.';
       switch (c)
 	{

libgfortran/io/read.c

@@ -439,9 +439,10 @@ read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
     read_utf8_char1 (dtp, p, length, w);
   else
     read_default_char1 (dtp, p, length, w);
-  
-  dtp->u.p.sf_read_comma =
-    dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
+
+  dtp->u.p.sf_read_comma = 1;
+  if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+    dtp->u.p.sf_read_comma = dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
 }
 
 
@@ -467,8 +468,9 @@ read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
   else
     read_default_char4 (dtp, p, length, w);
   
-  dtp->u.p.sf_read_comma =
-    dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
+  dtp->u.p.sf_read_comma = 1;
+  if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+    dtp->u.p.sf_read_comma = dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
 }
 
 /* eat_leading_spaces()-- Given a character pointer and a width,
@@ -840,8 +842,11 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
       switch (*p)
 	{
 	case ',':
-	  if (dtp->u.p.decimal_status == DECIMAL_COMMA && *p == ',')
-	    *p = '.';
+	  if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+	      && (dtp->u.p.decimal_status == DECIMAL_COMMA && *p == ','))
+		*p = '.';
+	  else
+	    goto bad_float;
 	  /* Fall through */
 	case '.':
 	  if (seen_dp)
@@ -1074,9 +1079,17 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 void
 read_x (st_parameter_dt * dtp, int n)
 {
-  if ((dtp->u.p.pad_status == PAD_NO || is_internal_unit (dtp))
-      && dtp->u.p.current_unit->bytes_left < n)
-    n = dtp->u.p.current_unit->bytes_left;
+  if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+    {
+      if ((dtp->u.p.pad_status == PAD_NO || is_internal_unit (dtp))
+	  && dtp->u.p.current_unit->bytes_left < n)
+	n = dtp->u.p.current_unit->bytes_left;
+    }
+  else
+    {
+      if (is_internal_unit (dtp) && dtp->u.p.current_unit->bytes_left < n)
+	n = dtp->u.p.current_unit->bytes_left;
+    }
 
   dtp->u.p.sf_read_comma = 0;
   if (n > 0)

libgfortran/io/write.c

@@ -65,7 +65,8 @@ write_default_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
     }
 
   /* Get ready to handle delimiters if needed.  */
-
+  d = ' ';
+  if (dtp->common.flags & IOPARM_DT_HAS_F2003)
   switch (dtp->u.p.delim_status)
     {
     case DELIM_APOSTROPHE:
@@ -128,7 +129,8 @@ write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
     }
 
   /* Get ready to handle delimiters if needed.  */
-
+  d = ' ';
+  if (dtp->common.flags & IOPARM_DT_HAS_F2003)
   switch (dtp->u.p.delim_status)
     {
     case DELIM_APOSTROPHE:
@@ -880,6 +882,8 @@ write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
   int i, extra;
   char *p, d;
 
+  d = ' ';
+  if (dtp->common.flags & IOPARM_DT_HAS_F2003)
   switch (dtp->u.p.delim_status)
     {
     case DELIM_APOSTROPHE:
@@ -1018,7 +1022,10 @@ write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
 static void
 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
 {
-  char semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
+  char semi_comma = ',';
+
+  if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+    semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
 
   if (write_char (dtp, '('))
     return;
@@ -1065,9 +1072,17 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
     }
   else
     {
-      if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
-	  dtp->u.p.delim_status != DELIM_NONE)
-	write_separator (dtp);
+      if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+	{
+	  if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
+	      dtp->u.p.delim_status != DELIM_NONE)
+	    write_separator (dtp);
+	}
+      else
+	{
+          if (type != BT_CHARACTER || !dtp->u.p.char_flag)
+	    write_separator (dtp);
+	}
     }
 
   switch (type)
@@ -1182,7 +1197,10 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
   /* Set the character to be used to separate values
      to a comma or semi-colon.  */
 
-  char semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
+  char semi_comma = ',';
+
+  if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+    semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
 
   /* Write namelist variable names in upper case. If a derived type,
      nothing is output.  If a component, base and base_name are set.  */
@@ -1297,13 +1315,18 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
               break;
 
 	    case GFC_DTYPE_CHARACTER:
-	      tmp_delim = dtp->u.p.delim_status;
-	      if (dtp->u.p.nml_delim == '"')
-		dtp->u.p.delim_status = DELIM_QUOTE;
-	      if (dtp->u.p.nml_delim == '\'')
-		dtp->u.p.delim_status = DELIM_APOSTROPHE;
-	      write_character (dtp, p, 1, obj->string_length);
-	      dtp->u.p.delim_status = tmp_delim;
+	      if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+		{
+		  tmp_delim = dtp->u.p.delim_status;
+		  if (dtp->u.p.nml_delim == '"')
+		    dtp->u.p.delim_status = DELIM_QUOTE;
+		  if (dtp->u.p.nml_delim == '\'')
+		    dtp->u.p.delim_status = DELIM_APOSTROPHE;
+		  write_character (dtp, p, 1, obj->string_length);
+		  dtp->u.p.delim_status = tmp_delim;
+		}
+	      else
+		write_character (dtp, p, 1, obj->string_length);
               break;
 
 	    case GFC_DTYPE_REAL:
@@ -1438,10 +1461,11 @@ namelist_write (st_parameter_dt *dtp)
   index_type dummy_offset = 0;
   char c;
   char * dummy_name = NULL;
-  unit_delim tmp_delim;
+  unit_delim tmp_delim = DELIM_UNSPECIFIED;
 
   /* Set the delimiter for namelist output.  */
-
+if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+  {
   tmp_delim = dtp->u.p.delim_status;
   switch (tmp_delim)
     {
@@ -1460,7 +1484,7 @@ namelist_write (st_parameter_dt *dtp)
 
   /* Temporarily disable namelist delimters.  */
   dtp->u.p.delim_status = DELIM_NONE;
-
+  }
   write_character (dtp, "&", 1, 1);
 
   /* Write namelist name in upper case - f95 std.  */
@@ -1483,7 +1507,8 @@ namelist_write (st_parameter_dt *dtp)
   write_character (dtp, "  /", 1, 3);
   namelist_write_newline (dtp);
   /* Restore the original delimiter.  */
-  dtp->u.p.delim_status = tmp_delim;
+  if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+    dtp->u.p.delim_status = tmp_delim;
 }
 
 #undef NML_DIGITS

libgfortran/io/write_float.def

@@ -55,6 +55,7 @@ calculate_sign (st_parameter_dt *dtp, int negative_flag)
 	s = S_NONE;
 	break;
       case SIGN_S:	/* Processor defined. */
+      case SIGN_UNSPECIFIED:
 	s = options.optional_plus ? S_PLUS : S_NONE;
 	break;
       }
@@ -403,7 +404,10 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
       out += nbefore;
     }
   /* Output the decimal point.  */
-  *(out++) = dtp->u.p.decimal_status == DECIMAL_POINT ? '.' : ',';
+  if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+    *(out++) = dtp->u.p.decimal_status == DECIMAL_POINT ? '.' : ',';
+  else
+    *(out++) = '.';
 
   /* Output leading zeros after the decimal point.  */
   if (nzero > 0)