diff mbox series

[fortran] PR fortran/96870 - Class name on error message

Message ID 7433359f-fa07-c881-009a-8722c2c5924d@gmail.com
State New
Headers show
Series [fortran] PR fortran/96870 - Class name on error message | expand

Commit Message

José Rui Faustino de Sousa Aug. 31, 2020, 4:09 p.m. UTC 
Hi all!

Proposed patch to PR96870 - Class name on error message.

Patch tested only on x86_64-pc-linux-gnu.

Make the error message more intelligible for the average user.

Thank you very much.

Best regards,
José Rui


	2020-8-21  José Rui Faustino de Sousa  <jrfsousa@gmail.com>

gcc/fortran/ChangeLog:

	PR fortran/96870
	* misc.c (gfc_typename): use class name instead of internal name
	on error message.

gcc/testsuite/ChangeLog:

	PR fortran/96870
	* gfortran.dg/PR96870.f90: New test.
diff mbox series

Patch

diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 65bcfa6..43edfd8 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -184,8 +184,11 @@  gfc_typename (gfc_typespec *ts, bool for_hash)
 	  break;
 	}
       ts1 = ts->u.derived->components ? &ts->u.derived->components->ts : NULL;
-      if (ts1 && ts1->u.derived && ts1->u.derived->attr.unlimited_polymorphic)
-	sprintf (buffer, "CLASS(*)");
+      if (ts1 && ts1->u.derived)
+	if (ts1->u.derived->attr.unlimited_polymorphic)
+	  sprintf (buffer, "CLASS(*)");
+	else
+	  sprintf (buffer, "CLASS(%s)", ts1->u.derived->name);
       else
 	sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
       break;
diff --git a/gcc/testsuite/gfortran.dg/PR96870.f90 b/gcc/testsuite/gfortran.dg/PR96870.f90
new file mode 100644
index 0000000..c1b321e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR96870.f90
@@ -0,0 +1,41 @@ 
+! { dg-do compile }
+!
+! Test fix for PR96870
+!
+
+Program main_p
+
+  implicit none
+  
+  Type :: t0
+  End Type t0
+  
+  Type, extends(t0) :: t1
+  End Type t1
+  
+  type(t0),   target :: x
+  class(t0), pointer :: p
+
+  p => x
+  Call sub_1(x) ! { dg-error "Type mismatch in argument .p. at .1.; passed TYPE\\(t0\\) to CLASS\\(t1\\)" }
+  Call sub_1(p) ! { dg-error "Type mismatch in argument .p. at .1.; passed CLASS\\(t0\\) to CLASS\\(t1\\)" }
+  Call sub_2(x) ! { dg-error "Type mismatch in argument .p. at .1.; passed TYPE\\(t0\\) to TYPE\\(t1\\)" }
+  Call sub_2(p) ! { dg-error "Type mismatch in argument .p. at .1.; passed CLASS\\(t0\\) to TYPE\\(t1\\)" }
+  stop
+  
+Contains
+  
+  Subroutine sub_1(p)
+    class(t1), Intent(In) :: p
+
+    return
+  End Subroutine sub_1
+  
+  Subroutine sub_2(p)
+    type(t1), Intent(In) :: p
+
+    return
+  End Subroutine sub_2
+  
+End Program main_p
+