Merge branch 'master' into devel/sphinx

9 files changed, 305 insertions, 14 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1352a54..e90248d 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,67 @@
+2022-09-04  José Rui Faustino de Sousa  <jrfsousa@gmail.com>
+
+	PR fortran/100136
+	* trans-expr.cc (gfc_conv_procedure_call): Add handling of pointer
+	expressions.
+
+2022-09-03  José Rui Faustino de Sousa  <jrfsousa@gmail.com>
+
+	PR fortran/100245
+	* trans-expr.cc (trans_class_assignment): Add if clause to handle
+	derived type in the LHS.
+
+2022-09-03  Jakub Jelinek  <jakub@redhat.com>
+
+	* trans-openmp.cc (gfc_trans_omp_clauses): Use
+	OMP_CLAUSE_DOACROSS_SINK_NEGATIVE instead of
+	OMP_CLAUSE_DEPEND_SINK_NEGATIVE, build OMP_CLAUSE_DOACROSS
+	clause instead of OMP_CLAUSE_DEPEND and set OMP_CLAUSE_DOACROSS_DEPEND
+	on it.
+
+2022-09-02  Harald Anlauf  <anlauf@gmx.de>
+	    Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/99349
+	* decl.cc (match_data_constant): Avoid NULL pointer dereference.
+
+2022-08-26  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/106579
+	* trans-intrinsic.cc: Include realmpfr.h.
+	(conv_intrinsic_ieee_value): New function.
+	(gfc_conv_ieee_arithmetic_function): Handle ieee_value.
+
+2022-08-26  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/106579
+	* f95-lang.cc (gfc_init_builtin_functions): Initialize
+	BUILT_IN_FPCLASSIFY.
+	* libgfortran.h (IEEE_OTHER_VALUE, IEEE_SIGNALING_NAN,
+	IEEE_QUIET_NAN, IEEE_NEGATIVE_INF, IEEE_NEGATIVE_NORMAL,
+	IEEE_NEGATIVE_DENORMAL, IEEE_NEGATIVE_SUBNORMAL,
+	IEEE_NEGATIVE_ZERO, IEEE_POSITIVE_ZERO, IEEE_POSITIVE_DENORMAL,
+	IEEE_POSITIVE_SUBNORMAL, IEEE_POSITIVE_NORMAL, IEEE_POSITIVE_INF):
+	New enum.
+	* trans-intrinsic.cc (conv_intrinsic_ieee_class): New function.
+	(gfc_conv_ieee_arithmetic_function): Handle ieee_class.
+
+2022-08-26  Jakub Jelinek  <jakub@redhat.com>
+
+	* f95-lang.cc (gfc_init_builtin_functions): Initialize
+	BUILT_IN_ISSIGNALING.
+
+2022-08-25  Tobias Burnus  <tobias@codesourcery.com>
+
+	* parse.cc (parse_omp_structured_block): When parsing strictly
+	structured blocks, issue an error if the end-directive comes
+	before the 'end block'.
+
+2022-08-24  Harald Anlauf  <anlauf@gmx.de>
+
+	PR fortran/103694
+	* simplify.cc (simplify_size): The size expression of an array cannot
+	be simplified if an error occurs while resolving the array spec.
+
 2022-08-22  Harald Anlauf  <anlauf@gmx.de>
 
 	PR fortran/106557
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index b640051..0f9b2ce 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -423,7 +423,8 @@ match_data_constant (gfc_expr **result)
 	 data-pointer-initialization compatible (7.5.4.6) with the initial
 	 data target; the data statement object is initially associated
 	 with the target.  */
-      if ((*result)->symtree->n.sym->attr.save
+      if ((*result)->symtree
+	  && (*result)->symtree->n.sym->attr.save
 	  && (*result)->symtree->n.sym->attr.target)
 	return m;
       gfc_free_expr (*result);
diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc
index 319cf8f..10ac8a9 100644
--- a/gcc/fortran/f95-lang.cc
+++ b/gcc/fortran/f95-lang.cc
@@ -1013,10 +1013,13 @@ gfc_init_builtin_functions (void)
 		      "__builtin_isnan", ATTR_CONST_NOTHROW_LEAF_LIST);
   gfc_define_builtin ("__builtin_isnormal", ftype, BUILT_IN_ISNORMAL,
 		      "__builtin_isnormal", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_issignaling", ftype, BUILT_IN_ISSIGNALING,
+		      "__builtin_issignaling", ATTR_CONST_NOTHROW_LEAF_LIST);
   gfc_define_builtin ("__builtin_signbit", ftype, BUILT_IN_SIGNBIT,
 		      "__builtin_signbit", ATTR_CONST_NOTHROW_LEAF_LIST);
+  gfc_define_builtin ("__builtin_fpclassify", ftype, BUILT_IN_FPCLASSIFY,
+		      "__builtin_fpclassify", ATTR_CONST_NOTHROW_LEAF_LIST);
 
-  ftype = build_function_type (integer_type_node, NULL_TREE);
   gfc_define_builtin ("__builtin_isless", ftype, BUILT_IN_ISLESS,
 		      "__builtin_isless", ATTR_CONST_NOTHROW_LEAF_LIST);
   gfc_define_builtin ("__builtin_islessequal", ftype, BUILT_IN_ISLESSEQUAL,
diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h
index 4328447..ef06194 100644
--- a/gcc/fortran/libgfortran.h
+++ b/gcc/fortran/libgfortran.h
@@ -187,3 +187,23 @@ typedef enum
   BT_ASSUMED, BT_UNION, BT_BOZ
 }
 bt;
+
+/* Enumeration of the possible floating-point types. These values
+   correspond to the hidden arguments of the IEEE_CLASS_TYPE
+   derived-type of IEEE_ARITHMETIC.  */
+
+enum {
+  IEEE_OTHER_VALUE = 0,
+  IEEE_SIGNALING_NAN,
+  IEEE_QUIET_NAN,
+  IEEE_NEGATIVE_INF,
+  IEEE_NEGATIVE_NORMAL,
+  IEEE_NEGATIVE_DENORMAL,
+  IEEE_NEGATIVE_SUBNORMAL = IEEE_NEGATIVE_DENORMAL,
+  IEEE_NEGATIVE_ZERO,
+  IEEE_POSITIVE_ZERO,
+  IEEE_POSITIVE_DENORMAL,
+  IEEE_POSITIVE_SUBNORMAL = IEEE_POSITIVE_DENORMAL,
+  IEEE_POSITIVE_NORMAL,
+  IEEE_POSITIVE_INF
+};
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 0b4c596..80492c9 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5709,7 +5709,7 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
 	    }
 	  return st;
 	}
-      else if (st != omp_end_st)
+      else if (st != omp_end_st || block_construct)
 	{
 	  unexpected_statement (st);
 	  st = next_statement ();
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index f992c31..bc178d5 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -7536,8 +7536,9 @@ simplify_size (gfc_expr *array, gfc_expr *dim, int k)
     }
 
   for (ref = array->ref; ref; ref = ref->next)
-    if (ref->type == REF_ARRAY && ref->u.ar.as)
-      gfc_resolve_array_spec (ref->u.ar.as, 0);
+    if (ref->type == REF_ARRAY && ref->u.ar.as
+	&& !gfc_resolve_array_spec (ref->u.ar.as, 0))
+      return NULL;
 
   if (dim == NULL)
     {
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 850007f..7895d03 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7220,16 +7220,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      else
 		goto end_pointer_check;
 
+	      tmp = parmse.expr;
 	      if (fsym && fsym->ts.type == BT_CLASS)
 		{
-		  tmp = build_fold_indirect_ref_loc (input_location,
-						      parmse.expr);
+		  if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+		    tmp = build_fold_indirect_ref_loc (input_location, tmp);
 		  tmp = gfc_class_data_get (tmp);
 		  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
 		    tmp = gfc_conv_descriptor_data_get (tmp);
 		}
-	      else
-		tmp = parmse.expr;
 
 	      /* If the argument is passed by value, we need to strip the
 		 INDIRECT_REF.  */
@@ -11436,6 +11435,9 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
       class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
 	  ? gfc_class_data_get (lse->expr) : lse->expr;
 
+      if (!POINTER_TYPE_P (TREE_TYPE (class_han)))
+	class_han = gfc_build_addr_expr (NULL_TREE, class_han);
+
       /* Allocate block.  */
       gfc_init_block (&alloc);
       gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 9d91278..ec116ff 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -41,6 +41,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "trans-array.h"
 #include "dependency.h"	/* For CAF array alias analysis.  */
 #include "attribs.h"
+#include "realmpfr.h"
 
 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
 
@@ -10013,6 +10014,199 @@ conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
 }
 
 
+/* Generate code for IEEE_CLASS.  */
+
+static void
+conv_intrinsic_ieee_class (gfc_se *se, gfc_expr *expr)
+{
+  tree arg, c, t1, t2, t3, t4;
+
+  /* Convert arg, evaluate it only once.  */
+  conv_ieee_function_args (se, expr, &arg, 1);
+  arg = gfc_evaluate_now (arg, &se->pre);
+
+  c = build_call_expr_loc (input_location,
+			   builtin_decl_explicit (BUILT_IN_FPCLASSIFY), 6,
+			   build_int_cst (integer_type_node, IEEE_QUIET_NAN),
+			   build_int_cst (integer_type_node,
+					  IEEE_POSITIVE_INF),
+			   build_int_cst (integer_type_node,
+					  IEEE_POSITIVE_NORMAL),
+			   build_int_cst (integer_type_node,
+					  IEEE_POSITIVE_DENORMAL),
+			   build_int_cst (integer_type_node,
+					  IEEE_POSITIVE_ZERO),
+			   arg);
+  c = gfc_evaluate_now (c, &se->pre);
+  t1 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
+			c, build_int_cst (integer_type_node,
+					  IEEE_QUIET_NAN));
+  t2 = build_call_expr_loc (input_location,
+			    builtin_decl_explicit (BUILT_IN_ISSIGNALING), 1,
+			    arg);
+  t2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+			t2, build_zero_cst (TREE_TYPE (t2)));
+  t1 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+			logical_type_node, t1, t2);
+  t3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
+			c, build_int_cst (integer_type_node,
+					  IEEE_POSITIVE_ZERO));
+  t4 = build_call_expr_loc (input_location,
+			    builtin_decl_explicit (BUILT_IN_SIGNBIT), 1,
+			    arg);
+  t4 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+			t4, build_zero_cst (TREE_TYPE (t4)));
+  t3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+			logical_type_node, t3, t4);
+  int s = IEEE_NEGATIVE_ZERO + IEEE_POSITIVE_ZERO;
+  gcc_assert (IEEE_NEGATIVE_INF == s - IEEE_POSITIVE_INF);
+  gcc_assert (IEEE_NEGATIVE_NORMAL == s - IEEE_POSITIVE_NORMAL);
+  gcc_assert (IEEE_NEGATIVE_DENORMAL == s - IEEE_POSITIVE_DENORMAL);
+  gcc_assert (IEEE_NEGATIVE_SUBNORMAL == s - IEEE_POSITIVE_SUBNORMAL);
+  gcc_assert (IEEE_NEGATIVE_ZERO == s - IEEE_POSITIVE_ZERO);
+  t4 = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (c),
+			build_int_cst (TREE_TYPE (c), s), c);
+  t3 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c),
+			t3, t4, c);
+  t1 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c), t1,
+			build_int_cst (TREE_TYPE (c), IEEE_SIGNALING_NAN),
+			t3);
+  tree type = gfc_typenode_for_spec (&expr->ts);
+  /* Perform a quick sanity check that the return type is
+     IEEE_CLASS_TYPE derived type defined in
+     libgfortran/ieee/ieee_arithmetic.F90
+     Primarily check that it is a derived type with a single
+     member in it.  */
+  gcc_assert (TREE_CODE (type) == RECORD_TYPE);
+  tree field = NULL_TREE;
+  for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
+    if (TREE_CODE (f) == FIELD_DECL)
+      {
+	gcc_assert (field == NULL_TREE);
+	field = f;
+      }
+  gcc_assert (field);
+  t1 = fold_convert (TREE_TYPE (field), t1);
+  se->expr = build_constructor_single (type, field, t1);
+}
+
+
+/* Generate code for IEEE_VALUE.  */
+
+static void
+conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr)
+{
+  tree args[2], arg, ret, tmp;
+  stmtblock_t body;
+
+  /* Convert args, evaluate the second one only once.  */
+  conv_ieee_function_args (se, expr, args, 2);
+  arg = gfc_evaluate_now (args[1], &se->pre);
+
+  tree type = TREE_TYPE (arg);
+  /* Perform a quick sanity check that the second argument's type is
+     IEEE_CLASS_TYPE derived type defined in
+     libgfortran/ieee/ieee_arithmetic.F90
+     Primarily check that it is a derived type with a single
+     member in it.  */
+  gcc_assert (TREE_CODE (type) == RECORD_TYPE);
+  tree field = NULL_TREE;
+  for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
+    if (TREE_CODE (f) == FIELD_DECL)
+      {
+	gcc_assert (field == NULL_TREE);
+	field = f;
+      }
+  gcc_assert (field);
+  arg = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			 arg, field, NULL_TREE);
+  arg = gfc_evaluate_now (arg, &se->pre);
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  gcc_assert (TREE_CODE (type) == REAL_TYPE);
+  ret = gfc_create_var (type, NULL);
+
+  gfc_init_block (&body);
+
+  tree end_label = gfc_build_label_decl (NULL_TREE);
+  for (int c = IEEE_SIGNALING_NAN; c <= IEEE_POSITIVE_INF; ++c)
+    {
+      tree label = gfc_build_label_decl (NULL_TREE);
+      tree low = build_int_cst (TREE_TYPE (arg), c);
+      tmp = build_case_label (low, low, label);
+      gfc_add_expr_to_block (&body, tmp);
+
+      REAL_VALUE_TYPE real;
+      int k;
+      switch (c)
+	{
+	case IEEE_SIGNALING_NAN:
+	  real_nan (&real, "", 0, TYPE_MODE (type));
+	  break;
+	case IEEE_QUIET_NAN:
+	  real_nan (&real, "", 1, TYPE_MODE (type));
+	  break;
+	case IEEE_NEGATIVE_INF:
+	  real_inf (&real);
+	  real = real_value_negate (&real);
+	  break;
+	case IEEE_NEGATIVE_NORMAL:
+	  real_from_integer (&real, TYPE_MODE (type), -42, SIGNED);
+	  break;
+	case IEEE_NEGATIVE_DENORMAL:
+	  k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
+	  real_from_mpfr (&real, gfc_real_kinds[k].tiny,
+			  type, GFC_RND_MODE);
+	  real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
+	  real = real_value_negate (&real);
+	  break;
+	case IEEE_NEGATIVE_ZERO:
+	  real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
+	  real = real_value_negate (&real);
+	  break;
+	case IEEE_POSITIVE_ZERO:
+	  /* Make this also the default: label.  The other possibility
+	     would be to add a separate default: label followed by
+	     __builtin_unreachable ().  */
+	  label = gfc_build_label_decl (NULL_TREE);
+	  tmp = build_case_label (NULL_TREE, NULL_TREE, label);
+	  gfc_add_expr_to_block (&body, tmp);
+	  real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
+	  break;
+	case IEEE_POSITIVE_DENORMAL:
+	  k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
+	  real_from_mpfr (&real, gfc_real_kinds[k].tiny,
+			  type, GFC_RND_MODE);
+	  real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
+	  break;
+	case IEEE_POSITIVE_NORMAL:
+	  real_from_integer (&real, TYPE_MODE (type), 42, SIGNED);
+	  break;
+	case IEEE_POSITIVE_INF:
+	  real_inf (&real);
+	  break;
+	default:
+	  gcc_unreachable ();
+	}
+
+      tree val = build_real (type, real);
+      gfc_add_modify (&body, ret, val);
+
+      tmp = build1_v (GOTO_EXPR, end_label);
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  tmp = gfc_finish_block (&body);
+  tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, arg, tmp);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  tmp = build1_v (LABEL_EXPR, end_label);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  se->expr = ret;
+}
+
+
 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
    module.  */
 
@@ -10043,6 +10237,10 @@ gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
     conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB);
   else if (startswith (name, "_gfortran_ieee_rint"))
     conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT);
+  else if (startswith (name, "ieee_class_") && ISDIGIT (name[11]))
+    conv_intrinsic_ieee_class (se, expr);
+  else if (startswith (name, "ieee_value_") && ISDIGIT (name[11]))
+    conv_intrinsic_ieee_value (se, expr);
   else
     /* It is not among the functions we translate directly.  We return
        false, so a library function call is emitted.  */
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index de27ed5..82c1079 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -2897,7 +2897,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 			    }
 			  vec = tree_cons (addend, t, vec);
 			  if (neg)
-			    OMP_CLAUSE_DEPEND_SINK_NEGATIVE (vec) = 1;
+			    OMP_CLAUSE_DOACROSS_SINK_NEGATIVE (vec) = 1;
 			}
 		      if (n->next == NULL
 			  || n->next->u.depend_op != OMP_DEPEND_SINK)
@@ -2908,8 +2908,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 		    continue;
 
 		  tree node = build_omp_clause (input_location,
-						OMP_CLAUSE_DEPEND);
-		  OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_SINK;
+						OMP_CLAUSE_DOACROSS);
+		  OMP_CLAUSE_DOACROSS_KIND (node) = OMP_CLAUSE_DOACROSS_SINK;
+		  OMP_CLAUSE_DOACROSS_DEPEND (node) = 1;
 		  OMP_CLAUSE_DECL (node) = nreverse (vec);
 		  omp_clauses = gfc_trans_add_clause (node, omp_clauses);
 		  continue;
@@ -4254,8 +4255,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 
   if (clauses->depend_source)
     {
-      c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEPEND);
-      OMP_CLAUSE_DEPEND_KIND (c) = OMP_CLAUSE_DEPEND_SOURCE;
+      c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DOACROSS);
+      OMP_CLAUSE_DOACROSS_KIND (c) = OMP_CLAUSE_DOACROSS_SOURCE;
+      OMP_CLAUSE_DOACROSS_DEPEND (c) = 1;
       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
     }