From 9e5aefa51df49a498854b25ce9dacd46bf58eb4e Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Mon, 9 May 2022 22:14:21 +0200
Subject: [PATCH] Fortran: check TEAM arguments to coarray intrinsics

TEAM arguments to coarray intrinsics must be scalar expressions of type
TEAM_TYPE of intrinsic module ISO_FORTRAN_ENV.

gcc/fortran/ChangeLog:

	PR fortran/105526
	* resolve.cc (check_team): New.
	(gfc_resolve_code): Add checks for arguments to coarray intrinsics
	FORM TEAM, CHANGE TEAM, and SYNC TEAM.

gcc/testsuite/ChangeLog:

	PR fortran/105526
	* gfortran.dg/coarray_50.f90: New test.
---
 gcc/fortran/resolve.cc                   | 32 ++++++++++++++++++++++++
 gcc/testsuite/gfortran.dg/coarray_50.f90 | 22 ++++++++++++++++
 2 files changed, 54 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/coarray_50.f90

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 29df531cdb6..c8335f939a9 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11831,6 +11831,23 @@ deferred_op_assign (gfc_code **code, gfc_namespace *ns)
 }


+static bool
+check_team (gfc_expr *team, const char *intrinsic)
+{
+  if (team->rank != 0
+      || team->ts.type != BT_DERIVED
+      || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+      || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
+    {
+      gfc_error ("TEAM argument to %qs at %L must be a scalar expression "
+		 "of type TEAM_TYPE", intrinsic, &team->where);
+      return false;
+    }
+
+  return true;
+}
+
+
 /* Given a block of code, recursively resolve everything pointed to by this
    code block.  */

@@ -11999,10 +12016,25 @@ start:
 	  break;

 	case EXEC_FAIL_IMAGE:
+	  break;
+
 	case EXEC_FORM_TEAM:
+	  if (code->expr1 != NULL
+	      && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
+	    gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be "
+		       "a scalar INTEGER", &code->expr1->where);
+	  check_team (code->expr2, "FORM TEAM");
+	  break;
+
 	case EXEC_CHANGE_TEAM:
+	  check_team (code->expr1, "CHANGE TEAM");
+	  break;
+
 	case EXEC_END_TEAM:
+	  break;
+
 	case EXEC_SYNC_TEAM:
+	  check_team (code->expr1, "SYNC TEAM");
 	  break;

 	case EXEC_ENTRY:
diff --git a/gcc/testsuite/gfortran.dg/coarray_50.f90 b/gcc/testsuite/gfortran.dg/coarray_50.f90
new file mode 100644
index 00000000000..e88d9d93f0e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_50.f90
@@ -0,0 +1,22 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/105526 - check TEAM arguments to coarray intrinsics
+
+subroutine p
+  use iso_fortran_env, only: team_type
+  implicit none
+  type(team_type) :: team
+  type t
+     integer :: i
+  end type t
+  type(t) :: z
+  form team (0, team)
+  form team (0, 0)      ! { dg-error "scalar expression of type TEAM_TYPE" }
+  form team (0, [team]) ! { dg-error "scalar expression of type TEAM_TYPE" }
+  form team ([0], team) ! { dg-error "scalar INTEGER" }
+  form team (0., team)  ! { dg-error "scalar INTEGER" }
+  change team (0)       ! { dg-error "scalar expression of type TEAM_TYPE" }
+  end team
+  sync team (0)         ! { dg-error "scalar expression of type TEAM_TYPE" }
+end
--
2.35.3