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

1 files changed, 130 insertions, 103 deletions

diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index c810f4d..e707fbc 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -264,7 +264,8 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error)
 	  /* Without padding, terminate the I/O statement without assigning
 	     the value.  With padding, the value still needs to be assigned,
 	     so we can just continue with a short read.  */
-	  if (dtp->u.p.pad_status == PAD_NO)
+	  if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+	      && dtp->u.p.pad_status == PAD_NO)
 	    {
 	      if (no_error)
 		break;
@@ -329,10 +330,11 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
 	   to unit record length and proceed, otherwise error.  */
 	  if (dtp->u.p.current_unit->unit_number == options.stdin_unit
 	      && dtp->u.p.current_unit->recl == DEFAULT_RECL)
-          dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+            dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
 	  else
 	    {
-	      if (dtp->u.p.pad_status == PAD_NO)
+	      if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+		  && dtp->u.p.pad_status == PAD_NO)
 		{
 		  /* Not enough data left.  */
 		  generate_error (&dtp->common, LIBERROR_EOR, NULL);
@@ -379,7 +381,8 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
 
   if (nread != *nbytes)
     {				/* Short read, this shouldn't happen.  */
-      if (dtp->u.p.pad_status == PAD_YES)
+      if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+	  && dtp->u.p.pad_status == PAD_YES)
 	*nbytes = nread;
       else
 	{
@@ -950,7 +953,11 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
   /* Set this flag so that commas in reads cause the read to complete before
      the entire field has been read.  The next read field will start right after
      the comma in the stream.  (Set to 0 for character reads).  */
-  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;
+
   dtp->u.p.line_buffer = scratch;
 
   for (;;)
@@ -1820,7 +1827,13 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
   namelist_info *ionml;
 
   ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
-  memset (&dtp->u.p, 0, sizeof (dtp->u.p));
+
+  /* To maintain ABI, &transfer is the start of the private memory area in
+     in st_parameter_dt.  Memory from the beginning of the structure to this
+     point is set by the front end and must not be touched.  The number of
+     bytes to clear must stay within the sizeof q to avoid over-writing.  */
+  memset (&dtp->u.p.transfer, 0, sizeof (dtp->u.q));
+
   dtp->u.p.ionml = ionml;
   dtp->u.p.mode = read_flag ? READING : WRITING;
 
@@ -1836,60 +1849,61 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
      st_parameter_open opp;
      unit_convert conv;
 
-     if (dtp->common.unit < 0)
-     {
-       close_unit (dtp->u.p.current_unit);
-       dtp->u.p.current_unit = NULL;
-       generate_error (&dtp->common, LIBERROR_BAD_OPTION,
-		       "Bad unit number in OPEN statement");
-       return;
-     }
-     memset (&u_flags, '\0', sizeof (u_flags));
-     u_flags.access = ACCESS_SEQUENTIAL;
-     u_flags.action = ACTION_READWRITE;
-
-     /* Is it unformatted?  */
-     if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
-		 | IOPARM_DT_IONML_SET)))
-       u_flags.form = FORM_UNFORMATTED;
-     else
-       u_flags.form = FORM_UNSPECIFIED;
-
-     u_flags.delim = DELIM_UNSPECIFIED;
-     u_flags.blank = BLANK_UNSPECIFIED;
-     u_flags.pad = PAD_UNSPECIFIED;
-     u_flags.decimal = DECIMAL_UNSPECIFIED;
-     u_flags.encoding = ENCODING_UNSPECIFIED;
-     u_flags.async = ASYNC_UNSPECIFIED;
-     u_flags.round = ROUND_UNSPECIFIED;
-     u_flags.sign = SIGN_UNSPECIFIED;
-     u_flags.status = STATUS_UNKNOWN;
-
-     conv = get_unformatted_convert (dtp->common.unit);
-
-     if (conv == GFC_CONVERT_NONE)
-       conv = compile_options.convert;
-
-     /* We use big_endian, which is 0 on little-endian machines
-	and 1 on big-endian machines.  */
-     switch (conv)
-       {
-       case GFC_CONVERT_NATIVE:
-       case GFC_CONVERT_SWAP:
-	 break;
+    if (dtp->common.unit < 0)
+      {
+	close_unit (dtp->u.p.current_unit);
+	dtp->u.p.current_unit = NULL;
+	generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+			"Bad unit number in OPEN statement");
+	return;
+      }
+    memset (&u_flags, '\0', sizeof (u_flags));
+    u_flags.access = ACCESS_SEQUENTIAL;
+    u_flags.action = ACTION_READWRITE;
+
+    /* Is it unformatted?  */
+    if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
+		| IOPARM_DT_IONML_SET)))
+      u_flags.form = FORM_UNFORMATTED;
+    else
+      u_flags.form = FORM_UNSPECIFIED;
+
+    u_flags.delim = DELIM_UNSPECIFIED;
+    u_flags.blank = BLANK_UNSPECIFIED;
+    u_flags.pad = PAD_UNSPECIFIED;
+    u_flags.decimal = DECIMAL_UNSPECIFIED;
+    u_flags.encoding = ENCODING_UNSPECIFIED;
+    u_flags.async = ASYNC_UNSPECIFIED;
+    u_flags.round = ROUND_UNSPECIFIED;
+    u_flags.sign = SIGN_UNSPECIFIED;
+
+    u_flags.status = STATUS_UNKNOWN;
+
+    conv = get_unformatted_convert (dtp->common.unit);
+
+    if (conv == GFC_CONVERT_NONE)
+      conv = compile_options.convert;
+
+    /* We use big_endian, which is 0 on little-endian machines
+       and 1 on big-endian machines.  */
+    switch (conv)
+      {
+	case GFC_CONVERT_NATIVE:
+	case GFC_CONVERT_SWAP:
+	  break;
 	 
-       case GFC_CONVERT_BIG:
-	 conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
-	 break;
+	case GFC_CONVERT_BIG:
+	  conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
+	  break;
       
-       case GFC_CONVERT_LITTLE:
-	 conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
-	 break;
+	case GFC_CONVERT_LITTLE:
+	  conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
+	  break;
 	 
-       default:
-	 internal_error (&opp.common, "Illegal value for CONVERT");
-	 break;
-       }
+	default:
+	  internal_error (&opp.common, "Illegal value for CONVERT");
+	  break;
+      }
 
      u_flags.convert = conv;
 
@@ -1970,7 +1984,8 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
       && (cf & IOPARM_DT_HAS_REC) != 0)
     {
       generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
-		      "Record number not allowed for sequential access data transfer");
+		      "Record number not allowed for sequential access "
+		      "data transfer");
       return;
     }
 
@@ -1986,7 +2001,8 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
       if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
 	{
 	  generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
-			  "ADVANCE specification conflicts with sequential access");
+			  "ADVANCE specification conflicts with sequential "
+			  "access");
 	  return;
 	}
 
@@ -2018,10 +2034,12 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
 	  return;
 	}
 
-      if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
+      if ((cf & IOPARM_DT_HAS_SIZE) != 0 
+	  && dtp->u.p.advance_status != ADVANCE_NO)
 	{
 	  generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
-			  "SIZE specification requires an ADVANCE specification of NO");
+			  "SIZE specification requires an ADVANCE "
+			  "specification of NO");
 	  return;
 	}
     }
@@ -2030,21 +2048,24 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
       if ((cf & IOPARM_END) != 0)
 	{
 	  generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
-			  "END specification cannot appear in a write statement");
+			  "END specification cannot appear in a write "
+			  "statement");
 	  return;
 	}
 
       if ((cf & IOPARM_EOR) != 0)
 	{
 	  generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
-			  "EOR specification cannot appear in a write statement");
+			  "EOR specification cannot appear in a write "
+			  "statement");
 	  return;
 	}
 
       if ((cf & IOPARM_DT_HAS_SIZE) != 0)
 	{
 	  generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
-			  "SIZE specification cannot appear in a write statement");
+			  "SIZE specification cannot appear in a write "
+			  "statement");
 	  return;
 	}
     }
@@ -2052,52 +2073,58 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
   if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
     dtp->u.p.advance_status = ADVANCE_YES;
 
-  /* Check the decimal mode.  */
-
-  dtp->u.p.decimal_status
-    = !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
-      find_option (&dtp->common, dtp->decimal, dtp->decimal_len, decimal_opt,
-		   "Bad DECIMAL parameter in data transfer statement");
+  /* To maintain ABI check these only if we have the F2003 flag set.  */
+  if(cf & IOPARM_DT_HAS_F2003)
+    {
+      /* Check the decimal mode.  */
+      dtp->u.p.decimal_status
+	= !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
+	  find_option (&dtp->common, dtp->u.p.decimal, dtp->u.p.decimal_len,
+			decimal_opt, "Bad DECIMAL parameter in data transfer "
+			"statement");
 
-  if (dtp->u.p.decimal_status == DECIMAL_UNSPECIFIED)
-    dtp->u.p.decimal_status = dtp->u.p.current_unit->flags.decimal;
+      if (dtp->u.p.decimal_status == DECIMAL_UNSPECIFIED)
+	dtp->u.p.decimal_status = dtp->u.p.current_unit->flags.decimal;
 
-  /* Check the sign mode. */
-  dtp->u.p.sign_status
-    = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
-      find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt,
-		   "Bad SIGN parameter in data transfer statement");
+      /* Check the sign mode. */
+      dtp->u.p.sign_status
+	= !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
+	  find_option (&dtp->common, dtp->u.p.sign, dtp->u.p.sign_len, sign_opt,
+			"Bad SIGN parameter in data transfer statement");
   
-  if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
-    dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
-
-  /* Check the blank mode.  */
-  dtp->u.p.blank_status
-    = !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED :
-      find_option (&dtp->common, dtp->blank, dtp->blank_len, blank_opt,
-		   "Bad BLANK parameter in data transfer statement");
+      if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
+	dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
+
+      /* Check the blank mode.  */
+      dtp->u.p.blank_status
+	= !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED :
+	  find_option (&dtp->common, dtp->u.p.blank, dtp->u.p.blank_len,
+			blank_opt,
+			"Bad BLANK parameter in data transfer statement");
   
-  if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
-    dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
+      if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
+	dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
   
-  /* Check the delim mode.  */
-  dtp->u.p.delim_status
-    = !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED :
-      find_option (&dtp->common, dtp->delim, dtp->delim_len, delim_opt,
-		   "Bad DELIM parameter in data transfer statement");
+      /* Check the delim mode.  */
+      dtp->u.p.delim_status
+	= !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED :
+	  find_option (&dtp->common, dtp->u.p.delim, dtp->u.p.delim_len,
+			delim_opt,
+			"Bad DELIM parameter in data transfer statement");
   
-  if (dtp->u.p.delim_status == DELIM_UNSPECIFIED)
-    dtp->u.p.delim_status = dtp->u.p.current_unit->flags.delim;
-
-  /* Check the pad mode.  */
-  dtp->u.p.pad_status
-    = !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED :
-      find_option (&dtp->common, dtp->pad, dtp->pad_len, pad_opt,
-		   "Bad PAD parameter in data transfer statement");
+      if (dtp->u.p.delim_status == DELIM_UNSPECIFIED)
+	dtp->u.p.delim_status = dtp->u.p.current_unit->flags.delim;
+
+      /* Check the pad mode.  */
+      dtp->u.p.pad_status
+	= !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED :
+	  find_option (&dtp->common, dtp->u.p.pad, dtp->u.p.pad_len, pad_opt,
+			"Bad PAD parameter in data transfer statement");
   
-  if (dtp->u.p.pad_status == PAD_UNSPECIFIED)
-    dtp->u.p.pad_status = dtp->u.p.current_unit->flags.pad;
- 
+      if (dtp->u.p.pad_status == PAD_UNSPECIFIED)
+	dtp->u.p.pad_status = dtp->u.p.current_unit->flags.pad;
+    }
+
   /* Sanity checks on the record number.  */
   if ((cf & IOPARM_DT_HAS_REC) != 0)
     {