Merge branch 'master' into devel/sphinx

3 files changed, 95 insertions, 42 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index dcbfd54..0559fc3 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,22 @@
+2022-10-01  José Rui Faustino de Sousa  <jrfsousa@gmail.com>
+
+	PR fortran/100040
+	PR fortran/100029
+	* trans-expr.cc (gfc_conv_class_to_class): Add code to have
+	assumed-rank arrays recognized as full arrays and fix the type
+	of the array assignment.
+	(gfc_conv_procedure_call): Change order of code blocks such that
+	the free of ALLOCATABLE dummy arguments with INTENT(OUT) occurs
+	first.
+
+2022-09-30  Tobias Burnus  <tobias@codesourcery.com>
+
+	PR fortran/105318
+	* openmp.cc (resolve_omp_clauses): Update is_device_ptr restrictions
+	for OpenMP 5.1 and map to has_device_addr where applicable; map
+	use_device_ptr to use_device_addr where applicable.
+	Silence integer-range warning for device(omp_{initial,invalid}_device).
+
 2022-09-27  Harald Anlauf  <anlauf@gmx.de>
 
 	PR fortran/107054
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 457e983..ce719bd 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -6511,7 +6511,7 @@ static void
 resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
 		     gfc_namespace *ns, bool openacc = false)
 {
-  gfc_omp_namelist *n;
+  gfc_omp_namelist *n, *last;
   gfc_expr_list *el;
   int list;
   int ifc;
@@ -7369,30 +7369,58 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
 		}
 	    break;
 	  case OMP_LIST_IS_DEVICE_PTR:
-	    for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
+	    last = NULL;
+	    for (n = omp_clauses->lists[list]; n != NULL; )
 	      {
-		if (!n->sym->attr.dummy)
-		  gfc_error ("Non-dummy object %qs in %s clause at %L",
-			     n->sym->name, name, &n->where);
-		if (n->sym->attr.allocatable
-		    || (n->sym->ts.type == BT_CLASS
-			&& CLASS_DATA (n->sym)->attr.allocatable))
-		  gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
-			     n->sym->name, name, &n->where);
-		if (n->sym->attr.pointer
-		    || (n->sym->ts.type == BT_CLASS
-			&& CLASS_DATA (n->sym)->attr.pointer))
-		  gfc_error ("POINTER object %qs in %s clause at %L",
-			     n->sym->name, name, &n->where);
-		if (n->sym->attr.value)
-		  gfc_error ("VALUE object %qs in %s clause at %L",
-			     n->sym->name, name, &n->where);
+		if (n->sym->ts.type == BT_DERIVED
+		    && n->sym->ts.u.derived->ts.is_iso_c
+		    && code->op != EXEC_OMP_TARGET)
+		  /* Non-TARGET (i.e. DISPATCH) requires a C_PTR.  */
+		  gfc_error ("List item %qs in %s clause at %L must be of "
+			     "TYPE(C_PTR)", n->sym->name, name, &n->where);
+		else if (n->sym->ts.type != BT_DERIVED
+			 || !n->sym->ts.u.derived->ts.is_iso_c)
+		  {
+		    /* For TARGET, non-C_PTR are deprecated and handled as
+		       has_device_addr.  */
+		    gfc_omp_namelist *n2 = n;
+		    n = n->next;
+		    if (last)
+		      last->next = n;
+		    else
+		      omp_clauses->lists[list] = n;
+		    n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
+		    omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2;
+		    continue;
+		  }
+		last = n;
+		n = n->next;
 	      }
 	    break;
 	  case OMP_LIST_HAS_DEVICE_ADDR:
-	  case OMP_LIST_USE_DEVICE_PTR:
 	  case OMP_LIST_USE_DEVICE_ADDR:
-	    /* FIXME: Handle OMP_LIST_USE_DEVICE_PTR.  */
+	    break;
+	  case OMP_LIST_USE_DEVICE_PTR:
+	    /* Non-C_PTR are deprecated and handled as use_device_ADDR.  */
+	    last = NULL;
+	    for (n = omp_clauses->lists[list]; n != NULL; )
+	      {
+		gfc_omp_namelist *n2 = n;
+		if (n->sym->ts.type != BT_DERIVED
+		    || !n->sym->ts.u.derived->ts.is_iso_c)
+		  {
+		    n = n->next;
+		    if (last)
+		      last->next = n;
+		    else
+		      omp_clauses->lists[list] = n;
+		    n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
+		    omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2;
+		    continue;
+		  }
+		last = n;
+		n = n->next;
+	      }
 	    break;
 	  default:
 	    for (; n != NULL; n = n->next)
@@ -7758,7 +7786,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
 		 &omp_clauses->num_teams_lower->where,
 		 &omp_clauses->num_teams_upper->where);
   if (omp_clauses->device)
-    resolve_nonnegative_int_expr (omp_clauses->device, "DEVICE");
+    resolve_scalar_int_expr (omp_clauses->device, "DEVICE");
   if (omp_clauses->filter)
     resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER");
   if (omp_clauses->hint)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 4f3ae82..1551a2e 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1178,8 +1178,10 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
     return;
 
   /* Test for FULL_ARRAY.  */
-  if (e->rank == 0 && gfc_expr_attr (e).codimension
-      && gfc_expr_attr (e).dimension)
+  if (e->rank == 0
+      && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension)
+	  || (class_ts.u.derived->components->as
+	      && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)))
     full_array = true;
   else
     gfc_is_class_array_ref (e, &full_array);
@@ -1227,8 +1229,12 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
 	  && e->rank != class_ts.u.derived->components->as->rank)
 	{
 	  if (e->rank == 0)
-	    gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
-			    gfc_conv_descriptor_data_get (ctree));
+	    {
+	      tmp = gfc_class_data_get (parmse->expr);
+	      gfc_add_modify (&parmse->post, tmp,
+			      fold_convert (TREE_TYPE (tmp),
+					 gfc_conv_descriptor_data_get (ctree)));
+	    }
 	  else
 	    class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
 	}
@@ -6560,23 +6566,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		    base_object = build_fold_indirect_ref_loc (input_location,
 							       parmse.expr);
 
-		  /* A class array element needs converting back to be a
-		     class object, if the formal argument is a class object.  */
-		  if (fsym && fsym->ts.type == BT_CLASS
-			&& e->ts.type == BT_CLASS
-			&& ((CLASS_DATA (fsym)->as
-			     && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
-			    || CLASS_DATA (e)->attr.dimension))
-		    gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
-				     fsym->attr.intent != INTENT_IN
-				     && (CLASS_DATA (fsym)->attr.class_pointer
-					 || CLASS_DATA (fsym)->attr.allocatable),
-				     fsym->attr.optional
-				     && e->expr_type == EXPR_VARIABLE
-				     && e->symtree->n.sym->attr.optional,
-				     CLASS_DATA (fsym)->attr.class_pointer
-				     || CLASS_DATA (fsym)->attr.allocatable);
-
 		  /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
 		     allocated on entry, it must be deallocated.  */
 		  if (fsym && fsym->attr.intent == INTENT_OUT
@@ -6637,6 +6626,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		      gfc_add_expr_to_block (&se->pre, tmp);
 		    }
 
+		  /* A class array element needs converting back to be a
+		     class object, if the formal argument is a class object.  */
+		  if (fsym && fsym->ts.type == BT_CLASS
+			&& e->ts.type == BT_CLASS
+			&& ((CLASS_DATA (fsym)->as
+			     && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
+			    || CLASS_DATA (e)->attr.dimension))
+		    gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
+				     fsym->attr.intent != INTENT_IN
+				     && (CLASS_DATA (fsym)->attr.class_pointer
+					 || CLASS_DATA (fsym)->attr.allocatable),
+				     fsym->attr.optional
+				     && e->expr_type == EXPR_VARIABLE
+				     && e->symtree->n.sym->attr.optional,
+				     CLASS_DATA (fsym)->attr.class_pointer
+				     || CLASS_DATA (fsym)->attr.allocatable);
+
 		  if (fsym && (fsym->ts.type == BT_DERIVED
 			       || fsym->ts.type == BT_ASSUMED)
 		      && e->ts.type == BT_CLASS