2008-12-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>

	PR fortran/38291
	* io.c (match_dt_element): Use dt->pos in matcher.
	(gfc_free_dt): Free dt->pos after use.
	(gfc_resolve_dt): Use dt->pos in resolution of stream position tag.

2008-12-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libfortran/38291
	* io/transfer.c (data_transfer_init): Add checks for POS= valid range.
	Add check for unit opened with ACCESS="stream". Flush and seek if
	current stream position does not match. Check ENDFILE on read.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@142515 138bc75d-0d04-0410-961f-82ee72b054a4

2 files changed, 75 insertions, 24 deletions

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index bb860d4816f..7aba0260ccd 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,10 @@
+2008-12-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR libfortran/38291
+	* io/transfer.c (data_transfer_init): Add checks for POS= valid range.
+	Add check for unit opened with ACCESS="stream". Flush and seek if
+	current stream position does not match. Check ENDFILE on read.
+
 2008-12-04  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/38285
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index c4fae32bead..4ddfd9f9a98 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -2116,6 +2116,62 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
   
   if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED)
 	dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad;
+  
+  /* Check the POS= specifier: that it is in range and that it is used with a
+     unit that has been connected for STREAM access. F2003 9.5.1.10.  */
+  
+  if (((cf & IOPARM_DT_HAS_POS) != 0))
+    {
+      if (is_stream_io (dtp))
+	{
+
+	  if (dtp->pos <= 0)
+	    {
+	      generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+			      "POS=specifier must be positive");
+	      return;
+	    }
+
+	  if (dtp->rec >= dtp->u.p.current_unit->maxrec)
+	    {
+	      generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+			      "POS=specifier too large");
+	      return;
+	    }
+
+	  dtp->rec = dtp->pos;
+
+	  if (dtp->u.p.mode == READING)
+	    {
+	      /* Required for compatibility between 4.3 and 4.4 runtime. Check
+	      to see if we might be reading what we wrote before  */
+	      if (dtp->u.p.current_unit->mode == WRITING)
+		flush(dtp->u.p.current_unit->s);
+
+	      if (dtp->pos < file_length (dtp->u.p.current_unit->s))
+		dtp->u.p.current_unit->endfile = NO_ENDFILE;
+	    }
+
+	  if (dtp->pos != dtp->u.p.current_unit->strm_pos)
+	    {
+	      fbuf_flush (dtp->u.p.current_unit, 1);
+	      flush (dtp->u.p.current_unit->s);
+	      if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1) == FAILURE)
+		{
+		  generate_error (&dtp->common, LIBERROR_OS, NULL);
+		  return;
+		}
+	      dtp->u.p.current_unit->strm_pos = dtp->pos;
+	    }
+	}
+      else
+	{
+	  generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+			  "POS=specifier not allowed, "
+			  "Try OPEN with ACCESS='stream'");
+	  return;
+	}
+    }
 
   /* Sanity checks on the record number.  */
   if ((cf & IOPARM_DT_HAS_REC) != 0)
@@ -2139,10 +2195,10 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
       if (dtp->u.p.mode == READING
 	  && dtp->u.p.current_unit->mode == WRITING
 	  && !is_internal_unit (dtp))
-        {
-          fbuf_flush (dtp->u.p.current_unit, 1);      
+	{
+	  fbuf_flush (dtp->u.p.current_unit, 1);      
 	  flush(dtp->u.p.current_unit->s);
-        }
+	}
 
       /* Check whether the record exists to be read.  Only
 	 a partial record needs to exist.  */
@@ -2156,29 +2212,17 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
 	}
 
       /* Position the file.  */
-      if (!is_stream_io (dtp))
+      if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
+		 * dtp->u.p.current_unit->recl) == FAILURE)
 	{
-	  if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
-		     * dtp->u.p.current_unit->recl) == FAILURE)
-	    {
-	      generate_error (&dtp->common, LIBERROR_OS, NULL);
-	      return;
-	    }
+	  generate_error (&dtp->common, LIBERROR_OS, NULL);
+	  return;
 	}
-      else
-        {
-	  if (dtp->u.p.current_unit->strm_pos != dtp->rec)
-	    {
-	      fbuf_flush (dtp->u.p.current_unit, 1);
-	      flush (dtp->u.p.current_unit->s);
-	      if (sseek (dtp->u.p.current_unit->s, dtp->rec - 1) == FAILURE)
-	        {
-	          generate_error (&dtp->common, LIBERROR_OS, NULL);
-	          return;
-	        }
-	      dtp->u.p.current_unit->strm_pos = dtp->rec;
-	    }
-        }
+
+      /* This is required to maintain compatibility between
+	 4.3 and 4.4 runtime.  */
+      if (is_stream_io (dtp))
+	dtp->u.p.current_unit->strm_pos = dtp->rec;
 
     }