From 3b15fe83830c1e75339114e0241e9d2158393017 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Tue, 4 Oct 2022 21:19:21 +0200
Subject: [PATCH] Fortran: reject procedures and procedure pointers as output
 item [PR107074]

gcc/fortran/ChangeLog:

	PR fortran/107074
	* trans-io.cc (transfer_expr): A procedure or a procedure pointer
	cannot be output items.

gcc/testsuite/ChangeLog:

	PR fortran/107074
	* gfortran.dg/pr107074.f90: New test.
---
 gcc/fortran/trans-io.cc                | 14 ++++++++++++++
 gcc/testsuite/gfortran.dg/pr107074.f90 | 11 +++++++++++
 2 files changed, 25 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/pr107074.f90

diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index 9f86815388c..c4e1537eed6 100644
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -2430,6 +2430,20 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,

       break;

+    case BT_PROCEDURE:
+      if (code->expr1
+	  && code->expr1->symtree
+	  && code->expr1->symtree->n.sym)
+	{
+	  if (code->expr1->symtree->n.sym->attr.proc_pointer)
+	    gfc_error ("Procedure pointer at %C cannot be an output item");
+	  else
+	    gfc_error ("Procedure at %C cannot be an output item");
+	  return;
+	}
+      /* If a PROCEDURE item gets through to here, fall through and ICE.  */
+      gcc_fallthrough ();
+
     case_bt_struct:
     case BT_CLASS:
       if (gfc_bt_struct (ts->type) || ts->type == BT_CLASS)
diff --git a/gcc/testsuite/gfortran.dg/pr107074.f90 b/gcc/testsuite/gfortran.dg/pr107074.f90
new file mode 100644
index 00000000000..a09088c2e9d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr107074.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! PR fortran/107074 - ICE: Bad IO basetype (8)
+! Contributed by G.Steinmetz
+
+program p
+  implicit none
+  integer, external        :: a
+  procedure(real), pointer :: b
+  print *, merge (a, a, .true.) ! { dg-error "Procedure" }
+  print *, merge (b, b, .true.) ! { dg-error "Procedure pointer" }
+end
--
2.35.3