[gcc r17-2906] fortran: [PR118793] Additional expanded namelist read diagnostics

https://gcc.gnu.org/g:86b7458e072b0651f8b04bcba64f5e2d1586bdec

commit r17-2906-g86b7458e072b0651f8b04bcba64f5e2d1586bdec
Author: Jerry DeLisle <[email protected]>
Date:   Tue Jul 28 19:02:36 2026 -0700

    fortran: [PR118793] Additional expanded namelist read diagnostics
    
    These changes add expanded diagnostics to error locations not addressed
    in the original patch. This is done by using a new helper function that
    saves the error message information for namelist related errors in a
    buffer and keeping a status bit in the st_parameter_dt structure.
    
            PR libfortran/118793
    
    libgfortran/ChangeLog:
    
            * io/io.h (NML_ERR_MSG_LEN): New macro.
            (st_parameter_dt): Add nml_err_pending bit.
            (gfc_unit): Add nml_err_msg.
            * io/list_read.c (nml_error): New function.
            (eat_separator): Use new function
            (convert_integer): Likewise.
            (convert_unsigned): Likewise.
            (parse_repeat): Likewise.  Save the position where the repeat
            count starts and report it.
            (read_logical): Likewise.
            (read_integer): Likewise.
            (parse_real): Likewise.
            (read_complex): Likewise.
            (read_real): Likewise.
            (check_type): Likewise.
            (list_formatted_read_scalar): Likewise.
            (read_character): Likewise.  Save the initial position of the value
            (nml_read_obj): Unwind to nml_err_ret on a deferred error.
            (namelist_read): Store deferred errors in the unit's nml_err_msg
            buffer.
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/namelist_101.f90: Fix dg-do directive typo and
            check the expanded diagnostic.
            * gfortran.dg/namelist_104.f90: New test.

Diff:
---
 gcc/testsuite/gfortran.dg/namelist_101.f90 |   6 +-
 gcc/testsuite/gfortran.dg/namelist_104.f90 |  21 +++++
 libgfortran/io/io.h                        |  12 ++-
 libgfortran/io/list_read.c                 | 119 ++++++++++++++++++++++-------
 4 files changed, 128 insertions(+), 30 deletions(-)

diff --git a/gcc/testsuite/gfortran.dg/namelist_101.f90 b/gcc/testsuite/gfortran.dg/namelist_101.f90
index 409c568f53f3..e6b33f876193 100644
--- a/gcc/testsuite/gfortran.dg/namelist_101.f90
+++ b/gcc/testsuite/gfortran.dg/namelist_101.f90
@@ -1,5 +1,7 @@
-! { dg-do run )
+! { dg-do run }
 ! { dg-shouldfail "Missing quote" }
+!
+! PR libfortran/118793
 program nml_quotes_bug
   implicit none
   integer      :: unit = 10
@@ -14,3 +16,5 @@ program nml_quotes_bug
   read (unit ,nml=tovs_obs_chan)
   close(unit ,status="delete")
 end program nml_quotes_bug
+! { dg-output "Missing quote while reading item 2 at line 3, column 10 in file .*(\r*\n+)" }
+! { dg-output "   c2 =  2a ,(\r*\n+)         \\^(\r*\n+)" }
diff --git a/gcc/testsuite/gfortran.dg/namelist_104.f90 b/gcc/testsuite/gfortran.dg/namelist_104.f90
new file mode 100644
index 000000000000..d45c07a762ba
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/namelist_104.f90
@@ -0,0 +1,21 @@
+! { dg-do run }
+! { dg-shouldfail "Missing quote" }
+!! PR118793 - Expanded namelist error messages
+!
+! Based on a testcase by Harald Anlauf
+program namelist_104
+  implicit none
+  integer      :: unit = 10
+  character(8) :: c1, c2
+  namelist /tovs_obs_chan/ c1, c2
+  open (unit ,file="nml-quotes-bug-104.nml")
+  write(unit,*) "&tovs_obs_chan"
+  write(unit,*) "  c1 = '1', c1 = '1',"
+  write(unit,*) "  c1 = '1', c1 = '1',  c2 = 2 ,"
+  write(unit,*) "/"
+  rewind(unit)
+  read (unit ,nml=tovs_obs_chan)
+  close(unit ,status="delete")
+end program namelist_104
+! { dg-output "Missing quote while reading item 5 at line 3, column 30 in file .*(\r*\n+)" }
+! { dg-output "   c1 = '1', c1 = '1',  c2 = 2 ,(\r*\n+)                             \\^(\r*\n+)" }
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index ecf1b779a483..87d32691ee8d 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -37,6 +37,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 /* Used for building error message strings.  */
 #define IOMSG_LEN 256
 
+/* Size of the namelist read error message buffer.  */
+#define NML_ERR_MSG_LEN 200
+
 /* POSIX 2008 specifies that the extended locale stuff is found in
    locale.h, but some systems have them in xlocale.h.  */
 
@@ -553,7 +556,10 @@ typedef struct st_parameter_dt
 	  unsigned expanded_read : 1;
 	  /* Flag to indicate if the statement has async="YES". */
 	  unsigned async : 1;
-	  /* 12 unused bits.  */
+	  /* A namelist specific flag set when a read error message has
+	     been saved into the unit's nml_err_msg buffer.  */
+	  unsigned nml_err_pending : 1;
+	  /* 11 unused bits.  */
 
 	  int child_saved_iostat;
 	  int nml_delim;
@@ -659,6 +665,10 @@ typedef struct gfc_unit
   /* Position information for better diagnostics.  */
   int line_number, column_number;
 
+  /* Error message buffer used while a namelist read is in progress.  Valid
+     only when the transfer's nml_err_pending flag is set.  */
+  char nml_err_msg[NML_ERR_MSG_LEN];
+
   enum
   { NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE }
   endfile;
diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index f2179e2a1d89..b9e45fab7bfd 100644
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -69,6 +69,24 @@ typedef unsigned char uchar;
 #define next_char(dtp) ((dtp)->u.p.current_unit->next_char_fn_ptr (dtp))
 #define push_char(dtp, c) ((dtp)->u.p.current_unit->push_char_fn_ptr (dtp, c))
 
+/* During a namelist read, the error message is saved to the namelist error
+   buffer and flagged as pending.  The saved message will be issued from
+   nml_read_obj.  Non namelist errors are issued now.  */
+
+static void
+nml_error (st_parameter_dt *dtp, int errcode, const char *message)
+{
+  if (dtp->u.p.namelist_mode)
+    {
+      snprintf (dtp->u.p.current_unit->nml_err_msg, NML_ERR_MSG_LEN, "%s",
+		message);
+      dtp->u.p.nml_err_pending = 1;
+      return;
+    }
+
+  generate_error (&dtp->common, errcode, message);
+}
+
 /* Worker function to save a default KIND=1 character to a string
    buffer, enlarging it as necessary.  */
 
@@ -516,8 +534,8 @@ eat_separator (st_parameter_dt *dtp)
     case ',':
       if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
 	{
-	  generate_error (&dtp->common, LIBERROR_READ_VALUE,
-	   "Comma not allowed as separator with DECIMAL='comma'");
+	  nml_error (dtp, LIBERROR_READ_VALUE,
+		     "Comma not allowed as separator with DECIMAL='comma'");
 	  unget_char (dtp, c);
 	  break;
 	}
@@ -528,8 +546,8 @@ eat_separator (st_parameter_dt *dtp)
     case ';':
       if (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT)
 	{
-	  generate_error (&dtp->common, LIBERROR_READ_VALUE,
-	   "Semicolon not allowed as separator with DECIMAL='point'");
+	  nml_error (dtp, LIBERROR_READ_VALUE,
+		     "Semicolon not allowed as separator with DECIMAL='point'");
 	  unget_char (dtp, c);
 	  break;
 	}
@@ -726,7 +744,7 @@ convert_integer (st_parameter_dt *dtp, int length, int negative)
 	  snprintf (message, IOMSG_LEN, "Zero repeat count in item %d of list "
 		    "input", dtp->u.p.item_count);
 
-	  generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+	  nml_error (dtp, LIBERROR_READ_VALUE, message);
 	  m = 1;
 	}
     }
@@ -743,7 +761,7 @@ convert_integer (st_parameter_dt *dtp, int length, int negative)
 	     dtp->u.p.item_count);
 
   free_saved (dtp);
-  generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+  nml_error (dtp, LIBERROR_READ_VALUE, message);
 
   return 1;
 }
@@ -805,7 +823,7 @@ convert_unsigned (st_parameter_dt *dtp, int length, int negative)
 	  snprintf (message, IOMSG_LEN, "Zero repeat count in item %d of list input",
 		   dtp->u.p.item_count);
 
-	  generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+	  nml_error (dtp, LIBERROR_READ_VALUE, message);
 	  m = 1;
 	}
     }
@@ -824,7 +842,7 @@ convert_unsigned (st_parameter_dt *dtp, int length, int negative)
 	      "item %d of list input", dtp->u.p.item_count);
 
   free_saved (dtp);
-  generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+  nml_error (dtp, LIBERROR_READ_VALUE, message);
 
   return 1;
 }
@@ -838,9 +856,16 @@ parse_repeat (st_parameter_dt *dtp)
 {
   char message[IOMSG_LEN];
   int c, repeat;
+  int initial_line = dtp->u.p.current_unit->line_number;
+  int initial_col = dtp->u.p.current_unit->column_number;
 
   if ((c = next_char (dtp)) == EOF)
     goto bad_repeat;
+
+  /* Remember where the repeat count starts, for diagnostics.  */
+  initial_line = dtp->u.p.current_unit->line_number;
+  initial_col = dtp->u.p.current_unit->column_number;
+
   switch (c)
     {
     CASE_DIGITS:
@@ -867,11 +892,16 @@ parse_repeat (st_parameter_dt *dtp)
 
 	  if (repeat > MAX_REPEAT)
 	    {
+	      if (dtp->u.p.namelist_mode)
+		{
+		  dtp->u.p.current_unit->line_number = initial_line;
+		  dtp->u.p.current_unit->column_number = initial_col;
+		}
 	      snprintf (message, IOMSG_LEN,
 		       "Repeat count overflow in item %d of list input",
 		       dtp->u.p.item_count);
 
-	      generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+	      nml_error (dtp, LIBERROR_READ_VALUE, message);
 	      return 1;
 	    }
 
@@ -880,11 +910,16 @@ parse_repeat (st_parameter_dt *dtp)
 	case '*':
 	  if (repeat == 0)
 	    {
+	      if (dtp->u.p.namelist_mode)
+		{
+		  dtp->u.p.current_unit->line_number = initial_line;
+		  dtp->u.p.current_unit->column_number = initial_col;
+		}
 	      snprintf (message, IOMSG_LEN,
 		       "Zero repeat count in item %d of list input",
 		       dtp->u.p.item_count);
 
-	      generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+	      nml_error (dtp, LIBERROR_READ_VALUE, message);
 	      return 1;
 	    }
 
@@ -910,9 +945,14 @@ parse_repeat (st_parameter_dt *dtp)
     }
   else
     eat_line (dtp);
+  if (dtp->u.p.namelist_mode)
+    {
+      dtp->u.p.current_unit->line_number = initial_line;
+      dtp->u.p.current_unit->column_number = initial_col;
+    }
   snprintf (message, IOMSG_LEN, "Bad repeat count in item %d of list input",
 	   dtp->u.p.item_count);
-  generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+  nml_error (dtp, LIBERROR_READ_VALUE, message);
   return 1;
 }
 
@@ -1081,7 +1121,7 @@ next:
   snprintf (message, IOMSG_LEN, "Bad logical value while reading item %d",
 	      dtp->u.p.item_count);
   free_line (dtp);
-  generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+  nml_error (dtp, LIBERROR_READ_VALUE, message);
   return;
 
  logical_done:
@@ -1254,7 +1294,7 @@ next:
 	      dtp->u.p.item_count);
 
   free_line (dtp);
-  generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+  nml_error (dtp, LIBERROR_READ_VALUE, message);
 
   return;
 
@@ -1290,13 +1330,18 @@ static void
 read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
 {
   char quote, message[IOMSG_LEN];
-  int c;
+  int c, initial_line, initial_col;
 
   quote = ' ';			/* Space means no quote character.  */
 
 next:
   if ((c = next_char (dtp)) == EOF)
     goto eof;
+
+  /* Save diagnostics info.  */
+  initial_line = dtp->u.p.current_unit->line_number;
+  initial_col = dtp->u.p.current_unit->column_number;
+
   if (c == ';')
     {
       push_char (dtp, c);
@@ -1364,9 +1409,15 @@ next:
 	     was a string of digits it should have had the closing quote.  */
 	  if (dtp->u.p.namelist_mode)
 	    {
+	      dtp->u.p.current_unit->line_number = initial_line;
+	      dtp->u.p.current_unit->column_number = initial_col;
 	      snprintf (message, IOMSG_LEN, "Missing quote while reading item %d",
 			dtp->u.p.item_count);
-	      generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+	      nml_error (dtp, LIBERROR_READ_VALUE, message);
+	      /* If there is a pending error, exit here to preserve the
+		 position information.  */
+	      if (dtp->u.p.nml_err_pending)
+		return;
 	    }
 	  unget_char (dtp, c);
 	  goto done;		/* String was only digits!  */
@@ -1420,9 +1471,14 @@ next:
      read should have been set.  */
   if (dtp->u.p.namelist_mode && (quote == ' '))
     {
+      dtp->u.p.current_unit->line_number = initial_line;
+      dtp->u.p.current_unit->column_number = initial_col;
       snprintf (message, IOMSG_LEN, "Missing quote while reading item %d",
 		dtp->u.p.item_count);
-      generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+      nml_error (dtp, LIBERROR_READ_VALUE, message);
+      /* Stop consuming input so the reported position stays put.  */
+      if (dtp->u.p.nml_err_pending)
+	return;
     }
 
   for (;;)
@@ -1493,7 +1549,7 @@ next:
       free_saved (dtp);
       snprintf (message, IOMSG_LEN, "Invalid string input in item %d",
 		  dtp->u.p.item_count);
-      generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+      nml_error (dtp, LIBERROR_READ_VALUE, message);
     }
   free_line (dtp);
   return;
@@ -1764,7 +1820,7 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
   snprintf (message, IOMSG_LEN, "Bad complex floating point "
 	    "number for item %d", dtp->u.p.item_count);
   free_line (dtp);
-  generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+  nml_error (dtp, LIBERROR_READ_VALUE, message);
 
   return 1;
 }
@@ -1880,7 +1936,7 @@ eol_4:
   snprintf (message, IOMSG_LEN, "Bad complex value in item %d of list input",
 	      dtp->u.p.item_count);
   free_line (dtp);
-  generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+  nml_error (dtp, LIBERROR_READ_VALUE, message);
 }
 
 
@@ -2360,7 +2416,7 @@ next:
   snprintf (message, IOMSG_LEN, "Bad real number in item %d of list input",
 	      dtp->u.p.item_count);
   free_line (dtp);
-  generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+  nml_error (dtp, LIBERROR_READ_VALUE, message);
 }
 
 
@@ -2378,7 +2434,7 @@ check_type (st_parameter_dt *dtp, bt type, int kind)
 		  type_name (dtp->u.p.saved_type), type_name (type),
 		  dtp->u.p.item_count);
       free_line (dtp);
-      generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+      nml_error (dtp, LIBERROR_READ_VALUE, message);
       return 1;
     }
 
@@ -2395,7 +2451,7 @@ check_type (st_parameter_dt *dtp, bt type, int kind)
 		  type_name (dtp->u.p.saved_type), kind,
 		  dtp->u.p.item_count);
       free_line (dtp);
-      generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+      nml_error (dtp, LIBERROR_READ_VALUE, message);
       return 1;
     }
 
@@ -2579,8 +2635,7 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
 	      free_line (dtp);
 	      fstrcpy (message, child_iomsg_len, child_iomsg, child_iomsg_len);
 	      message[child_iomsg_len] = '\0';
-	      generate_error (&dtp->common, dtp->u.p.child_saved_iostat,
-			      message);
+	      nml_error (dtp, dtp->u.p.child_saved_iostat, message);
 	    }
       }
       break;
@@ -3459,8 +3514,7 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset,
 		    child_iomsg_len = string_len_trim (IOMSG_LEN, child_iomsg);
 		    fstrcpy (message, child_iomsg_len, child_iomsg, child_iomsg_len);
 		    message[child_iomsg_len] = '\0';
-		    generate_error (&dtp->common, dtp->u.p.child_saved_iostat,
-				    message);
+		    nml_error (dtp, dtp->u.p.child_saved_iostat, message);
 		    goto nml_err_ret;
 		  }
 
@@ -3473,6 +3527,10 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset,
 	    internal_error (&dtp->common, nml_err_msg);
 	    goto nml_err_ret;
           }
+
+	  /* If there is a pending error, return now.  */
+	  if (dtp->u.p.nml_err_pending)
+	    return false;
         }
 
       /* The standard permits array data to stop short of the number of
@@ -3933,7 +3991,7 @@ void
 namelist_read (st_parameter_dt *dtp)
 {
   int c;
-  char nml_err_msg[200];
+  char *nml_err_msg = dtp->u.p.current_unit->nml_err_msg;
 
   /* Initialize the error string buffer just in case we get an unexpected fail
      somewhere and end up at nml_err_ret.  */
@@ -3947,6 +4005,9 @@ namelist_read (st_parameter_dt *dtp)
   dtp->u.p.input_complete = 0;
   dtp->u.p.expanded_read = 0;
 
+  /* Initialize the pending error flag.  */
+  dtp->u.p.nml_err_pending = 0;
+
   /* Set the next_char and push_char worker functions.  */
   set_workers (dtp);
 
@@ -4012,7 +4073,8 @@ find_nml_name:
 
   while (!dtp->u.p.input_complete)
     {
-      if (!nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg))
+      if (!nml_get_obj_data (dtp, &prev_nl, nml_err_msg, NML_ERR_MSG_LEN)
+	  || dtp->u.p.nml_err_pending)
 	goto nml_err_ret;
 
       /* Reset the previous namelist pointer if we know we are not going
@@ -4031,6 +4093,7 @@ nml_err_ret:
   /* All namelist error calls return from here */
   free_saved (dtp);
   free_line (dtp);
+  dtp->u.p.nml_err_pending = 0;
 
   if (dtp->u.p.current_unit)
     {