Merge branch 'master' into devel/sphinx

7 files changed, 110 insertions, 29 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8b80242..80f12c6e 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,51 @@
+2022-10-17  Steve Kargl  <kargl@gcc.gnu.org>
+
+	PR fortran/104330
+	* simplify.cc (gfc_simplify_image_index): Do not dereference NULL
+	pointer.
+
+2022-10-17  Harald Anlauf  <anlauf@gmx.de>
+	    Mikael Morin  <mikael@gcc.gnu.org>
+
+	PR fortran/93483
+	PR fortran/107216
+	PR fortran/107219
+	* arith.cc (reduce_unary): Handled expressions are EXP_CONSTANT and
+	EXPR_ARRAY.  Do not attempt to reduce otherwise.
+	(reduce_binary_ac): Likewise.
+	(reduce_binary_ca): Likewise.
+	(reduce_binary_aa): Moved check for EXP_CONSTANT and EXPR_ARRAY
+	from here ...
+	(reduce_binary): ... to here.
+	(eval_intrinsic): Catch failed reductions.
+	* gfortran.h (GFC_INTRINSIC_OPS): New enum ARITH_NOT_REDUCED to keep
+	track of expressions that were not reduced by the arithmetic evaluation
+	code.
+
+2022-10-17  Harald Anlauf  <anlauf@gmx.de>
+
+	PR fortran/107272
+	* arith.cc (gfc_arith_not): Operand must be of type BT_LOGICAL.
+	(gfc_arith_and): Likewise.
+	(gfc_arith_or): Likewise.
+	(gfc_arith_eqv): Likewise.
+	(gfc_arith_neqv): Likewise.
+	(gfc_arith_eq): Compare consistency of types of operands.
+	(gfc_arith_ne): Likewise.
+	(gfc_arith_gt): Likewise.
+	(gfc_arith_ge): Likewise.
+	(gfc_arith_lt): Likewise.
+	(gfc_arith_le): Likewise.
+
+2022-10-17  Tobias Burnus  <tobias@codesourcery.com>
+
+	PR fortran/107266
+	* trans-expr.cc (gfc_conv_string_parameter): Use passed
+	type to honor character kind.
+	* trans-types.cc (gfc_sym_type): Honor character kind.
+	* trans-decl.cc (gfc_conv_cfi_to_gfc): Fix handling kind=4
+	character strings.
+
 2022-10-14  Harald Anlauf  <anlauf@gmx.de>
 
 	PR fortran/100971
diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc
index 14ba931..fc9224eb 100644
--- a/gcc/fortran/arith.cc
+++ b/gcc/fortran/arith.cc
@@ -422,6 +422,9 @@ gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
 {
   gfc_expr *result;
 
+  if (op1->ts.type != BT_LOGICAL)
+    return ARITH_INVALID_TYPE;
+
   result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where);
   result->value.logical = !op1->value.logical;
   *resultp = result;
@@ -435,6 +438,9 @@ gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
+  if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
+    return ARITH_INVALID_TYPE;
+
   result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
 				  &op1->where);
   result->value.logical = op1->value.logical && op2->value.logical;
@@ -449,6 +455,9 @@ gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
+  if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
+    return ARITH_INVALID_TYPE;
+
   result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
 				  &op1->where);
   result->value.logical = op1->value.logical || op2->value.logical;
@@ -463,6 +472,9 @@ gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
+  if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
+    return ARITH_INVALID_TYPE;
+
   result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
 				  &op1->where);
   result->value.logical = op1->value.logical == op2->value.logical;
@@ -477,6 +489,9 @@ gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
+  if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
+    return ARITH_INVALID_TYPE;
+
   result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
 				  &op1->where);
   result->value.logical = op1->value.logical != op2->value.logical;
@@ -1187,6 +1202,9 @@ gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
+  if (op1->ts.type != op2->ts.type)
+    return ARITH_INVALID_TYPE;
+
   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
 				  &op1->where);
   result->value.logical = (op1->ts.type == BT_COMPLEX)
@@ -1203,6 +1221,9 @@ gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
+  if (op1->ts.type != op2->ts.type)
+    return ARITH_INVALID_TYPE;
+
   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
 				  &op1->where);
   result->value.logical = (op1->ts.type == BT_COMPLEX)
@@ -1219,6 +1240,9 @@ gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
+  if (op1->ts.type != op2->ts.type)
+    return ARITH_INVALID_TYPE;
+
   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
 				  &op1->where);
   result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
@@ -1233,6 +1257,9 @@ gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
+  if (op1->ts.type != op2->ts.type)
+    return ARITH_INVALID_TYPE;
+
   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
 				  &op1->where);
   result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
@@ -1247,6 +1274,9 @@ gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
+  if (op1->ts.type != op2->ts.type)
+    return ARITH_INVALID_TYPE;
+
   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
 				  &op1->where);
   result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
@@ -1261,6 +1291,9 @@ gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
+  if (op1->ts.type != op2->ts.type)
+    return ARITH_INVALID_TYPE;
+
   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
 				  &op1->where);
   result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
@@ -1282,14 +1315,14 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
   if (op->expr_type == EXPR_CONSTANT)
     return eval (op, result);
 
+  if (op->expr_type != EXPR_ARRAY)
+    return ARITH_NOT_REDUCED;
+
   rc = ARITH_OK;
   head = gfc_constructor_copy (op->value.constructor);
   for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
     {
-      if (c->expr->expr_type == EXPR_OP && c->expr->ts.type == BT_UNKNOWN)
-	rc = ARITH_INVALID_TYPE;
-      else
-	rc = reduce_unary (eval, c->expr, &r);
+      rc = reduce_unary (eval, c->expr, &r);
 
       if (rc != ARITH_OK)
 	break;
@@ -1330,8 +1363,8 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
 
       if (c->expr->expr_type == EXPR_CONSTANT)
         rc = eval (c->expr, op2, &r);
-      else if (c->expr->expr_type == EXPR_OP && c->expr->ts.type == BT_UNKNOWN)
-	rc = ARITH_INVALID_TYPE;
+      else if (c->expr->expr_type != EXPR_ARRAY)
+	rc = ARITH_NOT_REDUCED;
       else
 	rc = reduce_binary_ac (eval, c->expr, op2, &r);
 
@@ -1384,8 +1417,8 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
 
       if (c->expr->expr_type == EXPR_CONSTANT)
 	rc = eval (op1, c->expr, &r);
-      else if (c->expr->expr_type == EXPR_OP && c->expr->ts.type == BT_UNKNOWN)
-	rc = ARITH_INVALID_TYPE;
+      else if (c->expr->expr_type != EXPR_ARRAY)
+	rc = ARITH_NOT_REDUCED;
       else
 	rc = reduce_binary_ca (eval, op1, c->expr, &r);
 
@@ -1445,11 +1478,7 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
        c && d;
        c = gfc_constructor_next (c), d = gfc_constructor_next (d))
     {
-      if ((c->expr->expr_type == EXPR_OP && c->expr->ts.type == BT_UNKNOWN)
-	  || (d->expr->expr_type == EXPR_OP && d->expr->ts.type == BT_UNKNOWN))
-	rc = ARITH_INVALID_TYPE;
-      else
-	rc = reduce_binary (eval, c->expr, d->expr, &r);
+      rc = reduce_binary (eval, c->expr, d->expr, &r);
 
       if (rc != ARITH_OK)
 	break;
@@ -1490,6 +1519,9 @@ reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
   if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
     return reduce_binary_ac (eval, op1, op2, result);
 
+  if (op1->expr_type != EXPR_ARRAY || op2->expr_type != EXPR_ARRAY)
+    return ARITH_NOT_REDUCED;
+
   return reduce_binary_aa (eval, op1, op2, result);
 }
 
@@ -1668,7 +1700,7 @@ eval_intrinsic (gfc_intrinsic_op op,
   else
     rc = reduce_binary (eval.f3, op1, op2, &result);
 
-  if (rc == ARITH_INVALID_TYPE)
+  if (rc == ARITH_INVALID_TYPE || rc == ARITH_NOT_REDUCED)
     goto runtime;
 
   /* Something went wrong.  */
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 10bb098..6bd8800 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -222,11 +222,12 @@ enum gfc_intrinsic_op
    Assumptions are made about the numbering of the interface_op enums.  */
 #define GFC_INTRINSIC_OPS GFC_INTRINSIC_END
 
-/* Arithmetic results.  */
+/* Arithmetic results.  ARITH_NOT_REDUCED is used to keep track of expressions
+   that were not reduced by the arithmetic evaluation code.  */
 enum arith
 { ARITH_OK = 1, ARITH_OVERFLOW, ARITH_UNDERFLOW, ARITH_NAN,
   ARITH_DIV0, ARITH_INCOMMENSURATE, ARITH_ASYMMETRIC, ARITH_PROHIBIT,
-  ARITH_WRONGCONCAT, ARITH_INVALID_TYPE
+  ARITH_WRONGCONCAT, ARITH_INVALID_TYPE, ARITH_NOT_REDUCED
 };
 
 /* Statements.  */
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 6ac92cf..9c2fea8 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -8266,7 +8266,7 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
     if (ref->type == REF_COMPONENT)
       as = ref->u.ar.as;
 
-  if (as->type == AS_DEFERRED)
+  if (!as || as->type == AS_DEFERRED)
     return NULL;
 
   /* "valid sequence of cosubscripts" are required; thus, return 0 unless
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 5d16d64..4b570c3 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -7378,13 +7378,13 @@ done:
   /* Set string length for len=:, only.  */
   if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length)
     {
-      tmp = sym->ts.u.cl->backend_decl;
+      tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+      tmp = fold_convert (TREE_TYPE (tmp2), sym->ts.u.cl->backend_decl);
       if (sym->ts.kind != 1)
 	tmp = fold_build2_loc (input_location, MULT_EXPR,
-			       gfc_array_index_type,
-			       sym->ts.u.cl->backend_decl, tmp);
-      tmp2 = gfc_get_cfi_desc_elem_len (cfi);
-      gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
+			       TREE_TYPE (tmp2), tmp,
+			       build_int_cst (TREE_TYPE (tmp2), sym->ts.kind));
+      gfc_add_modify (&block, tmp2, tmp);
     }
 
   if (!sym->attr.dimension)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 1551a2e..e7b9211 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -10374,15 +10374,15 @@ gfc_conv_string_parameter (gfc_se * se)
        || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
       && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
     {
+      type = TREE_TYPE (se->expr);
       if (TREE_CODE (se->expr) != INDIRECT_REF)
-	{
-	  type = TREE_TYPE (se->expr);
-          se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
-	}
+	se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
       else
 	{
-	  type = gfc_get_character_type_len (gfc_default_character_kind,
-					     se->string_length);
+	  if (TREE_CODE (type) == ARRAY_TYPE)
+	    type = TREE_TYPE (type);
+	  type = gfc_get_character_type_len_for_eltype (type,
+							se->string_length);
 	  type = build_pointer_type (type);
 	  se->expr = gfc_build_addr_expr (type, se->expr);
 	}
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index c062a5b..fdce56d 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -2314,7 +2314,7 @@ gfc_sym_type (gfc_symbol * sym, bool is_bind_c)
 	      && sym->ns->proc_name->attr.is_bind_c)
 	  || (sym->ts.deferred && (!sym->ts.u.cl
 				   || !sym->ts.u.cl->backend_decl))))
-    type = gfc_character1_type_node;
+    type = gfc_get_char_type (sym->ts.kind);
   else
     type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension);