fortran: [PR118793] Provide expanded diagnostics for namelist read

The change implements additional diagnostic information for namelist
read. In particular, error messages provide line number, column
position, the specific file name, and a portion of the input line
where the error ocurred.

	PR libfortran/118793

libgfortran/ChangeLog:

	* io/file_pos.c (st_rewind): Reset line and column numbers.
	* io/io.h: Add line and column number to the gfc_unit
	structure.
	* io/list_read.c (next_char_default): Increment the column
	position and line number as needed.
	(next_char_internal): Likewise.
	(next_char_utf8): Likewise.
	(nml_err_ret): Build the expanded diagnostic message.
	* io/unit.c (insert_unit): Initialize the line_number.

gcc/testsuite/ChangeLog:

	* gfortran.dg/namelist_40.f90: Update expected dg-output.
	* gfortran.dg/namelist_47.f90: Likewise

diff --git a/gcc/testsuite/gfortran.dg/namelist_40.f90 b/gcc/testsuite/gfortran.dg/namelist_40.f90
index ba28d29e5b4d17904f53d4a3b53bdc3a96115f65..96d360f52238809c5f6a7cc3ba067fbda72ee8f5 100644 (file)
--- a/gcc/testsuite/gfortran.dg/namelist_40.f90
+++ b/gcc/testsuite/gfortran.dg/namelist_40.f90
@@ -31,7 +31,7 @@ contains
 
 subroutine writenml (astring)
   character(40), intent(in)  :: astring
-  character(300)   :: errmessage
+  character(500)   :: errmessage
   integer          :: ierror
 
   open (10, status="scratch", delim='apostrophe')
@@ -47,7 +47,11 @@ subroutine writenml (astring)
 end subroutine writenml
 
 end program namelist_40
-! { dg-output "Multiple sub-objects with non-zero rank in namelist object x%m%ch(\r*\n+)" }
-! { dg-output "Missing colon in substring qualifier for namelist variable x%m%ch(\r*\n+)" }
-! { dg-output "Substring out of range for namelist variable x%m%ch(\r*\n+)" }
-! { dg-output "Bad character in substring qualifier for namelist variable x%m%ch(\r*\n+)" }
+! { dg-output "Multiple sub-objects with non-zero rank in namelist object x%m%ch at line 2, column 20 in file .*(\r*\n+)" }
+! { dg-output " x\\(2\\)%m%ch\\(:\\)\\(2:2\\) = 'z','z',.*(\r*\n+)                   \\^(\r*\n+)(\r*\n+)" }
+! { dg-output "Missing colon in substring qualifier for namelist variable x%m%ch at line 2, column 19 in file .*(\r*\n+)" }
+! { dg-output " x\\(2\\)%m\\(2\\)%ch\\(:\\)\\(2\\) = 'z','z',.*(\r*\n+)                  \\^(\r*\n+)(\r*\n+)" }
+! { dg-output "Substring out of range for namelist variable x%m%ch at line 2, column 20 in file .*(\r*\n+)" }
+! { dg-output " x\\(2\\)%m\\(2\\)%ch\\(:\\)\\(:3\\) = 'z','z',.*(\r*\n+)                   \\^(\r*\n+)(\r*\n+)" }
+! { dg-output "Bad character in substring qualifier for namelist variable x%m%ch at line 2, column 20 in file .*(\r*\n+)" }
+! { dg-output " x\\(2\\)%m\\(2\\)%ch\\(1:2\\)\\(k:\\) = 'z','z',.*(\r*\n+)                   \\^" }

diff --git a/gcc/testsuite/gfortran.dg/namelist_47.f90 b/gcc/testsuite/gfortran.dg/namelist_47.f90
index 1000aba0575bb9939fde4f511ab594313503f89a..0c53dde407577bbfeebda8f6364494496b529677 100644 (file)
--- a/gcc/testsuite/gfortran.dg/namelist_47.f90
+++ b/gcc/testsuite/gfortran.dg/namelist_47.f90
@@ -29,7 +29,7 @@ contains
 
 subroutine writenml (astring)
   character(140), intent(in)  :: astring
-  character(300)   :: errmessage
+  character(500)   :: errmessage
   integer          :: ierror
 
   open (10, status="scratch", delim='apostrophe')
@@ -45,7 +45,7 @@ subroutine writenml (astring)
 end subroutine writenml
 
 end program namelist_47
-! { dg-output "Multiple sub-objects with non-zero rank in namelist object x%m%c012345678901234567890123456789012345678901234567890123456789h(\r*\n+)" }
-! { dg-output "Missing colon in substring qualifier for namelist variable x%m%c012345678901234567890123456789012345678901234567890123456789h(\r*\n+)" }
-! { dg-output "Substring out of range for namelist variable x%m%c012345678901234567890123456789012345678901234567890123456789h(\r*\n+)" }
-! { dg-output "Bad character in substring qualifier for namelist variable x%m%c012345678901234567890123456789012345678901234567890123456789h(\r*\n+)" }
+! { dg-output "Multiple sub-objects with non-zero rank in namelist object x%m%c012345678901234567890123456789012345678901234567890123456789h at line 2, column 80 in file .*(\r*\n+)" }
+! { dg-output "Missing colon in substring qualifier for namelist variable x%m%c012345678901234567890123456789012345678901234567890123456789h at line 2, column 79 in file .*(\r*\n+)" }
+! { dg-output "Substring out of range for namelist variable x%m%c012345678901234567890123456789012345678901234567890123456789h at line 2, column 80 in file .*(\r*\n+)" }
+! { dg-output "Bad character in substring qualifier for namelist variable x%m%c012345678901234567890123456789012345678901234567890123456789h at line 2, column 80 in file .*" }

diff --git a/libgfortran/io/file_pos.c b/libgfortran/io/file_pos.c
index dd04ba454553a0966ef3c054d293063a796e8cae..ecf18ba1fcf16858dde062c6132b177dbbb41c74 100644 (file)
--- a/libgfortran/io/file_pos.c
+++ b/libgfortran/io/file_pos.c
@@ -480,6 +480,8 @@ st_rewind (st_parameter_filepos *fpp)
          
          u->current_record = 0;
          u->strm_pos = 1;
+         u->line_number = 1;
+         u->column_number = 0;
          u->read_bad = 0;
          u->last_char = EOF - 1;
        }

diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index d131d9544c4f4fc1c66cb47309c2df76fa79c2d1..ade0bef32d528304f0a2602585ed8594bcd9390c 100644 (file)
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -656,6 +656,9 @@ typedef struct gfc_unit
 
   int read_bad, current_record, saved_pos, previous_nonadvancing_write;
 
+  /* Position information for better diagnostics.  */
+  int line_number, column_number;
+
   enum
   { NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE }
   endfile;

diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index 757f2faac238fe8034068aac990c2f207b3a52ad..2b577baa7d3cf688356fee8853da39513e8cea97 100644 (file)
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -211,6 +211,14 @@ next_char_default (st_parameter_dt *dtp)
   if (c != EOF && is_stream_io (dtp))
     dtp->u.p.current_unit->strm_pos++;
 
+  if (c == '\n')
+    {
+      dtp->u.p.current_unit->line_number++;
+      dtp->u.p.current_unit->column_number = 0;
+    }
+  else if (c != EOF)
+    dtp->u.p.current_unit->column_number++;
+
   dtp->u.p.at_eol = (c == '\n' || c == EOF);
   return c;
 }
@@ -241,6 +249,8 @@ next_char_internal (st_parameter_dt *dtp)
          int finished;
 
          c = '\n';
+         dtp->u.p.current_unit->line_number++;
+         dtp->u.p.current_unit->column_number = 0;
          record = next_array_record (dtp, dtp->u.p.current_unit->ls,
                                      &finished);
 
@@ -302,6 +312,14 @@ next_char_internal (st_parameter_dt *dtp)
     }
   dtp->u.p.current_unit->bytes_left--;
 
+  if (c == '\n')
+    {
+      dtp->u.p.current_unit->line_number++;
+      dtp->u.p.current_unit->column_number = 0;
+    }
+  else if (c != EOF)
+    dtp->u.p.current_unit->column_number++;
+
 done:
   dtp->u.p.at_eol = (c == '\n' || c == EOF);
   return c;
@@ -355,6 +373,14 @@ next_char_utf8 (st_parameter_dt *dtp)
     goto invalid;
 
 utf_done:
+  if (c == '\n')
+    {
+      dtp->u.p.current_unit->line_number++;
+      dtp->u.p.current_unit->column_number = 0;
+    }
+  else if (c != (gfc_char4_t) EOF)
+    dtp->u.p.current_unit->column_number++;
+
   dtp->u.p.at_eol = (c == '\n' || c == (gfc_char4_t) EOF);
   return (int) c;
 
@@ -3920,6 +3946,77 @@ nml_err_ret:
   /* All namelist error calls return from here */
   free_saved (dtp);
   free_line (dtp);
-  generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
+
+  if (dtp->u.p.current_unit)
+    {
+      int line = dtp->u.p.current_unit->line_number;
+      int col = dtp->u.p.current_unit->column_number;
+      char *filename = dtp->u.p.current_unit->filename;
+      char *detailed_msg;
+
+      char *line_text = NULL;
+      int line_len = 0;
+
+      if (is_internal_unit (dtp) && dtp->internal_unit)
+       {
+         GFC_IO_INT recl = dtp->u.p.current_unit->recl;
+         line_text = dtp->internal_unit + (line - 1) * recl;
+         line_len = recl;
+       }
+      else if (dtp->u.p.current_unit->fbuf)
+       {
+         struct fbuf *fb = dtp->u.p.current_unit->fbuf;
+         ptrdiff_t pos = fb->pos;
+         if (pos > 0)
+           {
+             ptrdiff_t start = pos - 1;
+             while (start > 0 && fb->buf[start-1] != '\n')
+               start--;
+             ptrdiff_t end = pos - 1;
+
+             /* Scan the buffer to get a fixed length of the text, but
+                don't exceed thr length of the line.  */
+             while (end < (ptrdiff_t)fb->act
+                    && (fb->buf[end] != '\n')
+                    && (end - start < 128))
+               end++;
+             line_text = fb->buf + start;
+             line_len = end - start;
+           }
+       }
+
+      size_t msg_len = strlen (nml_err_msg) + 200;
+      if (line_text) msg_len += line_len + col + 10;
+      if (filename) msg_len += strlen (filename);
+
+      detailed_msg = xmalloc (msg_len);
+      int offset;
+      if (filename)
+       offset = sprintf (detailed_msg, "%s at line %lld, column %lld in file %s",
+                  nml_err_msg, (long long) line, (long long) col, filename);
+      else
+       offset = sprintf (detailed_msg, "%s at line %lld, column %lld",
+                  nml_err_msg, (long long) line, (long long) col);
+
+      if (line_text && line_len > 0)
+       {
+         detailed_msg[offset++] = '\n';
+         memcpy (detailed_msg + offset, line_text, line_len);
+         offset += line_len;
+         detailed_msg[offset++] = '\n';
+
+         for (int i = 0; i < col - 1; i++)
+           detailed_msg[offset++] = ' ';
+         detailed_msg[offset++] = '^';
+         detailed_msg[offset++] = '\n';
+         detailed_msg[offset] = '\0';
+       }
+
+      generate_error (&dtp->common, LIBERROR_READ_VALUE, detailed_msg);
+      free (detailed_msg);
+    }
+  else
+    generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
+
   return;
 }

diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c
index fac24db014dcd0fb52f3006fc69ae6ab4f17f81d..84acfbdff98a10850539cef938880193fd457c63 100644 (file)
--- a/libgfortran/io/unit.c
+++ b/libgfortran/io/unit.c
@@ -238,6 +238,7 @@ insert_unit (int n)
 {
   gfc_unit *u = xcalloc (1, sizeof (gfc_unit));
   u->unit_number = n;
+  u->line_number = 1;
   u->internal_unit_kind = 0;
 #ifdef __GTHREAD_MUTEX_INIT
   {