re PR libfortran/26136 (List directed input with underfilled (logicals) array read incorrectly)

2006-02-28  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libgfortran/26136
	* io/io.h: Add flag for reading from line_buffer.
	* io/list_read.c (l_push_char): New function to save namelist
	input when reading logicals.
	(free_line): New function to free line_buffer memory.
	(next_char): Added feature to read from line_buffer.
	(read_logical): Use new functions to test for '=' after reading a
	logical value, checking for possible variable name.
	(namelist_read): Use free_line when all done.

From-SVN: r111597

libgfortran/ChangeLog

+2006-02-28  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR libgfortran/26136
+	* io/io.h: Add flag for reading from line_buffer.
+	* io/list_read.c (l_push_char): New function to save namelist
+	input when reading logicals.
+	(free_line): New function to free line_buffer memory.
+	(next_char): Added feature to read from line_buffer.
+	(read_logical): Use new functions to test for '=' after reading a
+	logical value, checking for possible variable name.
+	(namelist_read): Use free_line when all done.
+
 2006-02-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR libgfortran/26464

libgfortran/io/io.h

@@ -371,7 +371,9 @@ typedef struct st_parameter_dt
 	  void (*transfer) (struct st_parameter_dt *, bt, void *, int,
 			    size_t, size_t);
 	  struct gfc_unit *current_unit;
-	  int item_count; /* Item number in a formatted data transfer.  */
+	  /* Item number in a formatted data transfer.  Also used in namelist
+	       read_logical as an index into line_buffer.  */
+	  int item_count;
 	  unit_mode mode;
 	  unit_blank blank_status;
 	  enum {SIGN_S, SIGN_SS, SIGN_SP} sign_status;
@@ -409,7 +411,10 @@ typedef struct st_parameter_dt
 	     character string is being read so don't use commas to shorten a
 	     formatted field width.  */
 	  unsigned sf_read_comma : 1;
-	  /* 19 unused bits.  */
+          /* A namelist specific flag used to enable reading input from 
+	       line_buffer for logical reads.  */
+	  unsigned line_buffer_enabled : 1;
+	  /* 18 unused bits.  */
 
 	  char last_char;
 	  char nml_delim;

libgfortran/io/list_read.c

@@ -117,6 +117,19 @@ free_saved (st_parameter_dt *dtp)
 }
 
 
+/* Free the line buffer if necessary.  */
+
+static void
+free_line (st_parameter_dt *dtp)
+{
+  if (dtp->u.p.line_buffer == NULL)
+    return;
+
+  free_mem (dtp->u.p.line_buffer);
+  dtp->u.p.line_buffer = NULL;
+}
+
+
 static char
 next_char (st_parameter_dt *dtp)
 {
@@ -132,7 +145,23 @@ next_char (st_parameter_dt *dtp)
       goto done;
     }
 
-  length = 1;
+  /* Read from line_buffer if enabled.  */
+
+  if (dtp->u.p.line_buffer_enabled)
+    {
+      dtp->u.p.at_eol = 0;
+
+      c = dtp->u.p.line_buffer[dtp->u.p.item_count];
+      if (c != '\0' && dtp->u.p.item_count < 64)
+	{
+	  dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0';
+	  dtp->u.p.item_count++;
+	  goto done;
+	}
+
+        dtp->u.p.item_count = 0;
+	dtp->u.p.line_buffer_enabled = 0;
+    }    
 
   /* Handle the end-of-record condition for internal array unit */
   if (is_array_io(dtp) && dtp->u.p.current_unit->bytes_left == 0)
@@ -154,6 +183,9 @@ next_char (st_parameter_dt *dtp)
     }
 
   /* Get the next character and handle end-of-record conditions */
+
+  length = 1;
+
   p = salloc_r (dtp->u.p.current_unit->s, &length);
 
   if (is_internal_unit(dtp))
@@ -510,39 +542,69 @@ parse_repeat (st_parameter_dt *dtp)
 }
 
 
+/* To read a logical we have to look ahead in the input stream to make sure
+    there is not an equal sign indicating a variable name.  To do this we use 
+    line_buffer to point to a temporary buffer, pushing characters there for
+    possible later reading. */
+
+static void
+l_push_char (st_parameter_dt *dtp, char c)
+{
+  char *new;
+
+  if (dtp->u.p.line_buffer == NULL)
+    {
+      dtp->u.p.line_buffer = get_mem (SCRATCH_SIZE);
+      memset (dtp->u.p.line_buffer, 0, SCRATCH_SIZE);
+    }
+
+  dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
+}
+
+
 /* Read a logical character on the input.  */
 
 static void
 read_logical (st_parameter_dt *dtp, int length)
 {
   char c, message[100];
-  int v;
+  int i, v;
 
   if (parse_repeat (dtp))
     return;
 
-  c = next_char (dtp);
+  c = tolower (next_char (dtp));
+  l_push_char (dtp, c);
   switch (c)
     {
     case 't':
-    case 'T':
       v = 1;
+      c = next_char (dtp);
+      l_push_char (dtp, c);
+
+      if (!is_separator(c))
+	goto possible_name;
+
+      unget_char (dtp, c);
       break;
     case 'f':
-    case 'F':
       v = 0;
-      break;
+      c = next_char (dtp);
+      l_push_char (dtp, c);
 
+      if (!is_separator(c))
+	goto possible_name;
+
+      unget_char (dtp, c);
+      break;
     case '.':
-      c = next_char (dtp);
+      c = tolower (next_char (dtp));
       switch (c)
 	{
 	  case 't':
-	case 'T':
 	    v = 1;
 	    break;
 	  case 'f':
-	case 'F':
 	    v = 0;
 	    break;
 	  default:
@@ -572,10 +634,43 @@ read_logical (st_parameter_dt *dtp, int length)
 
   unget_char (dtp, c);
   eat_separator (dtp);
-  free_saved (dtp);
+  dtp->u.p.item_count = 0;
+  dtp->u.p.line_buffer_enabled = 0;
+  set_integer ((int *) dtp->u.p.value, v, length);
+
+  return;
+
+ possible_name:
+
+  for(i = 0; i < 63; i++)
+    {
+      c = next_char (dtp);
+      if (is_separator(c))
+	{
+	  unget_char (dtp, c);
+	  eat_separator (dtp);
+	  c = next_char (dtp);
+	  if (c != '=')
+	    {
+	      unget_char (dtp, c);
+	      dtp->u.p.item_count = 0;
+	      dtp->u.p.line_buffer_enabled = 0;
+	      dtp->u.p.saved_type = BT_LOGICAL;
+	      dtp->u.p.saved_length = length;
 	      set_integer ((int *) dtp->u.p.value, v, length);
+	      return;
+	    }
+	}
  
+      l_push_char (dtp, c);
+      if (c == '=')
+	{
+	  dtp->u.p.nml_read_error = 1;
+	  dtp->u.p.line_buffer_enabled = 1;
+	  dtp->u.p.item_count = 0;
 	  return;
+	}
+     }
 
  bad_logical:
 
@@ -2435,6 +2530,7 @@ find_nml_name:
 
   dtp->u.p.eof_jump = NULL;
   free_saved (dtp);
+  free_line (dtp);
   return;
 
   /* All namelist error calls return from here */
@@ -2443,6 +2539,7 @@ nml_err_ret:
 
   dtp->u.p.eof_jump = NULL;
   free_saved (dtp);
+  free_line (dtp);
   generate_error (&dtp->common, ERROR_READ_VALUE, nml_err_msg);
   return;
 }