From ebf9b6c13f0847ddcc22e540a5fcdbf644e85a9c Mon Sep 17 00:00:00 2001
From: Tobias Burnus <tobias@codesourcery.com>
Date: Tue, 16 Feb 2021 14:17:35 +0100
Subject: [PATCH] Fortran: Reject DT as fmt in I/O statments [PR99111]

gcc/fortran/ChangeLog:

	PR fortran/99111
	* io.c (resolve_tag_format): Reject BT_DERIVED/CLASS/VOID
	as (array-valued) FORMAT tag.

gcc/testsuite/ChangeLog:

	PR fortran/99111
	* gfortran.dg/fmt_nonchar_1.f90: New test.
	* gfortran.dg/fmt_nonchar_2.f90: New test.
---
 gcc/fortran/io.c                            |  7 ++++
 gcc/testsuite/gfortran.dg/fmt_nonchar_1.f90 | 46 +++++++++++++++++++++
 gcc/testsuite/gfortran.dg/fmt_nonchar_2.f90 | 22 ++++++++++
 3 files changed, 75 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/fmt_nonchar_1.f90
 create mode 100644 gcc/testsuite/gfortran.dg/fmt_nonchar_2.f90

diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index da6ad177ec3..40cd76eb585 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -1762,6 +1762,13 @@ resolve_tag_format (gfc_expr *e)
      It may be assigned an Hollerith constant.  */
   if (e->ts.type != BT_CHARACTER)
     {
+      if (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS
+	  || e->ts.type == BT_VOID)
+	{
+	  gfc_error ("Non-character non-Hollerith in FORMAT tag at %L",
+		     &e->where);
+	  return false;
+	}
       if (!gfc_notify_std (GFC_STD_LEGACY, "Non-character in FORMAT tag "
 			   "at %L", &e->where))
 	return false;
diff --git a/gcc/testsuite/gfortran.dg/fmt_nonchar_1.f90 b/gcc/testsuite/gfortran.dg/fmt_nonchar_1.f90
new file mode 100644
index 00000000000..431b61569e2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/fmt_nonchar_1.f90
@@ -0,0 +1,46 @@
+! { dg-do compile }
+!
+! PR fortran/99111
+!
+program p
+   use iso_c_binding
+   implicit none
+   type t
+      integer :: a(1)
+   end type
+   type(t), parameter :: x(3) = [t(transfer('("he', 1)), &
+                                 t(transfer('llo ', 1)), &
+                                 t(transfer('W1")', 1))]
+   type t2
+     procedure(), pointer, nopass :: ppt
+   end type t2
+   type(t2) :: ppcomp(1)
+   interface
+     function fptr()
+       procedure(), pointer :: fptr
+     end function
+   end interface
+   class(t), allocatable :: cl(:)
+   type(c_ptr) :: cptr(1)
+   type(c_funptr) :: cfunptr(1)
+   procedure(), pointer :: proc
+   external proc2
+
+   print x ! { dg-error "Non-character non-Hollerith in FORMAT tag" }
+   print cl ! { dg-error "Non-character non-Hollerith in FORMAT tag" }
+   print cptr ! { dg-error "Non-character non-Hollerith in FORMAT tag" }
+   print cfunptr ! { dg-error "Non-character non-Hollerith in FORMAT tag" }
+
+   print proc ! { dg-error "Syntax error in PRINT statement" }
+   print proc2 ! { dg-error "Syntax error in PRINT statement" }
+   print ppcomp%ppt ! { dg-error "Syntax error in PRINT statement" }
+
+   print fptr() ! { dg-error "must be of type default-kind CHARACTER or of INTEGER" }
+
+   call bar(1)
+contains
+   subroutine bar (xx)
+     type(*) :: xx
+     print xx  ! { dg-error "Assumed-type variable xx at ... may only be used as actual argument" }
+   end
+end
diff --git a/gcc/testsuite/gfortran.dg/fmt_nonchar_2.f90 b/gcc/testsuite/gfortran.dg/fmt_nonchar_2.f90
new file mode 100644
index 00000000000..7c0f524c3c9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/fmt_nonchar_2.f90
@@ -0,0 +1,22 @@
+! { dg-do run }
+!
+! PR fortran/99111
+!
+program p
+   implicit none
+   type t
+      integer :: a(1)
+   end type
+   type(t), parameter :: x(3) = [t(transfer('("he', 1)), &
+                                 t(transfer('llo ', 1)), &
+                                 t(transfer('W1")', 1))]
+
+   integer, parameter :: y(3) = transfer('("hello W2")', 1, size=3)
+   real, parameter :: z(3) = transfer('("hello W3")', 1.0, size=3)
+
+   print y      ! { dg-warning "Legacy Extension: Non-character in FORMAT" }
+   print z      ! { dg-warning "Legacy Extension: Non-character in FORMAT" }
+   print x%a(1) ! { dg-warning "Legacy Extension: Non-character in FORMAT" }
+end
+
+! { dg-output "hello W2(\n|\r\n|\r)hello W3(\n|\r\n|\r)hello W1" }
-- 
2.30.2