From 297363774e6a5dca2f46a85ab086f1d9e59431ac Mon Sep 17 00:00:00 2001
From: Paul Thomas <pault@gcc.gnu.org>
Date: Sun, 28 Mar 2021 16:48:27 +0100
Subject: Fortran: Fix problem with runtime pointer check [PR99602].

2021-03-28  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran/ChangeLog

	PR fortran/99602
	* trans-expr.c (gfc_conv_procedure_call): Use the _data attrs
	for class expressions and detect proc pointer evaluations by
	the non-null actual argument list.

gcc/testsuite/ChangeLog

	PR fortran/99602
	* gfortran.dg/pr99602.f90: New test.
	* gfortran.dg/pr99602a.f90: New test.
	* gfortran.dg/pr99602b.f90: New test.
	* gfortran.dg/pr99602c.f90: New test.
	* gfortran.dg/pr99602d.f90: New test.
---
 gcc/fortran/trans-expr.c | 28 ++++++++++++++++++++--------
 1 file changed, 20 insertions(+), 8 deletions(-)

(limited to 'gcc/fortran/trans-expr.c')

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index bffe080..2fa17b3 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6663,6 +6663,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  char *msg;
 	  tree cond;
 	  tree tmp;
+	  symbol_attribute fsym_attr;
+
+	  if (fsym)
+	    {
+	      if (fsym->ts.type == BT_CLASS)
+		{
+		  fsym_attr = CLASS_DATA (fsym)->attr;
+		  fsym_attr.pointer = fsym_attr.class_pointer;
+		}
+	      else
+		fsym_attr = fsym->attr;
+	    }
 
 	  if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
 	    attr = gfc_expr_attr (e);
@@ -6685,17 +6697,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      tree present, null_ptr, type;
 
 	      if (attr.allocatable
-		  && (fsym == NULL || !fsym->attr.allocatable))
+		  && (fsym == NULL || !fsym_attr.allocatable))
 		msg = xasprintf ("Allocatable actual argument '%s' is not "
 				 "allocated or not present",
 				 e->symtree->n.sym->name);
 	      else if (attr.pointer
-		       && (fsym == NULL || !fsym->attr.pointer))
+		       && (fsym == NULL || !fsym_attr.pointer))
 		msg = xasprintf ("Pointer actual argument '%s' is not "
 				 "associated or not present",
 				 e->symtree->n.sym->name);
-	      else if (attr.proc_pointer
-		       && (fsym == NULL || !fsym->attr.proc_pointer))
+	      else if (attr.proc_pointer && !e->value.function.actual
+		       && (fsym == NULL || !fsym_attr.proc_pointer))
 		msg = xasprintf ("Proc-pointer actual argument '%s' is not "
 				 "associated or not present",
 				 e->symtree->n.sym->name);
@@ -6719,15 +6731,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
           else
 	    {
 	      if (attr.allocatable
-		  && (fsym == NULL || !fsym->attr.allocatable))
+		  && (fsym == NULL || !fsym_attr.allocatable))
 		msg = xasprintf ("Allocatable actual argument '%s' is not "
 				 "allocated", e->symtree->n.sym->name);
 	      else if (attr.pointer
-		       && (fsym == NULL || !fsym->attr.pointer))
+		       && (fsym == NULL || !fsym_attr.pointer))
 		msg = xasprintf ("Pointer actual argument '%s' is not "
 				 "associated", e->symtree->n.sym->name);
-	      else if (attr.proc_pointer
-		       && (fsym == NULL || !fsym->attr.proc_pointer))
+	      else if (attr.proc_pointer && !e->value.function.actual
+		       && (fsym == NULL || !fsym_attr.proc_pointer))
 		msg = xasprintf ("Proc-pointer actual argument '%s' is not "
 				 "associated", e->symtree->n.sym->name);
 	      else
-- 
cgit v1.1


From 9a0e09f3dd5339bb18cc47317f2298d9157ced29 Mon Sep 17 00:00:00 2001
From: Paul Thomas <pault@gcc.gnu.org>
Date: Thu, 15 Apr 2021 07:34:26 +0100
Subject: Fortran: Fix class reallocate on assignment [PR99307].

2021-04-15  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/99307
	* symbol.c: Remove trailing white space.
	* trans-array.c (gfc_trans_create_temp_array): Create a class
	temporary for class expressions and assign the new descriptor
	to the data field.
	(build_class_array_ref): If the class expr can be extracted,
	then use that for 'decl'. Class function results are reliably
	handled this way. Call gfc_find_and_cut_at_last_class_ref to
	eliminate largely redundant code. Remove dead code and recast
	the rest of the code to extract 'decl' for remaining cases.
	Call gfc_build_spanned_array_ref.
	(gfc_alloc_allocatable_for_assignment): Use class descriptor
	element length for 'elemsize1'. Eliminate repeat set of dtype
	for class expressions.
	* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Include
	additional code from build_class_array_ref, and use optional
	gfc_typespec pointer argument.
	(gfc_trans_scalar_assign): Make use of pre and post blocks for
	all class expressions.
	* trans.c (get_array_span): For unlimited polymorphic exprs
	multiply the span by the value of the _len field.
	(gfc_build_spanned_array_ref): New function.
	(gfc_build_array_ref): Call gfc_build_spanned_array_ref and
	eliminate repeated code.
	* trans.h: Add arg to gfc_find_and_cut_at_last_class_ref and
	add prototype for gfc_build_spanned_array_ref.
---
 gcc/fortran/trans-expr.c | 98 ++++++++++++++++++++++++++++++++++--------------
 1 file changed, 69 insertions(+), 29 deletions(-)

(limited to 'gcc/fortran/trans-expr.c')

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 2fa17b3..213f32b 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -380,15 +380,20 @@ gfc_vptr_size_get (tree vptr)
 #undef VTABLE_FINAL_FIELD
 
 
-/* Search for the last _class ref in the chain of references of this
-   expression and cut the chain there.  Albeit this routine is similiar
-   to class.c::gfc_add_component_ref (), is there a significant
-   difference: gfc_add_component_ref () concentrates on an array ref to
-   be the last ref in the chain.  This routine is oblivious to the kind
-   of refs following.  */
+/* IF ts is null (default), search for the last _class ref in the chain
+   of references of the expression and cut the chain there.  Although
+   this routine is similiar to class.c:gfc_add_component_ref (), there
+   is a significant difference: gfc_add_component_ref () concentrates
+   on an array ref that is the last ref in the chain and is oblivious
+   to the kind of refs following.
+   ELSE IF ts is non-null the cut is at the class entity or component
+   that is followed by an array reference, which is not an element.
+   These calls come from trans-array.c:build_class_array_ref, which
+   handles scalarized class array references.*/
 
 gfc_expr *
-gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold)
+gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
+				    gfc_typespec **ts)
 {
   gfc_expr *base_expr;
   gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
@@ -396,27 +401,59 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold)
   /* Find the last class reference.  */
   class_ref = NULL;
   array_ref = NULL;
-  for (ref = e->ref; ref; ref = ref->next)
+
+  if (ts)
     {
-      if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
-	array_ref = ref;
+      if (e->symtree
+	  && e->symtree->n.sym->ts.type == BT_CLASS)
+	*ts = &e->symtree->n.sym->ts;
+      else
+	*ts = NULL;
+    }
 
-      if (ref->type == REF_COMPONENT
-	  && ref->u.c.component->ts.type == BT_CLASS)
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ts)
 	{
-	  /* Component to the right of a part reference with nonzero rank
-	     must not have the ALLOCATABLE attribute.  If attempts are
-	     made to reference such a component reference, an error results
-	     followed by an ICE.  */
-	  if (array_ref && CLASS_DATA (ref->u.c.component)->attr.allocatable)
-	    return NULL;
-	  class_ref = ref;
+	  if (ref->type == REF_COMPONENT
+	      && ref->u.c.component->ts.type == BT_CLASS
+	      && ref->next && ref->next->type == REF_COMPONENT
+	      && !strcmp (ref->next->u.c.component->name, "_data")
+	      && ref->next->next
+	      && ref->next->next->type == REF_ARRAY
+	      && ref->next->next->u.ar.type != AR_ELEMENT)
+	    {
+	      *ts = &ref->u.c.component->ts;
+	      class_ref = ref;
+	      break;
+	    }
+
+	  if (ref->next == NULL)
+	    break;
 	}
+      else
+	{
+	  if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
+	    array_ref = ref;
 
-      if (ref->next == NULL)
-	break;
+	  if (ref->type == REF_COMPONENT
+	      && ref->u.c.component->ts.type == BT_CLASS)
+	    {
+	      /* Component to the right of a part reference with nonzero
+		 rank must not have the ALLOCATABLE attribute.  If attempts
+		 are made to reference such a component reference, an error
+		 results followed by an ICE.  */
+	      if (array_ref
+		  && CLASS_DATA (ref->u.c.component)->attr.allocatable)
+		return NULL;
+	      class_ref = ref;
+	    }
+	}
     }
 
+  if (ts && *ts == NULL)
+    return NULL;
+
   /* Remove and store all subsequent references after the
      CLASS reference.  */
   if (class_ref)
@@ -10005,17 +10042,20 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
       gfc_add_modify (&block, lse->expr, tmp);
     }
   /* If possible use the rhs vptr copy with trans_scalar_class_assign....  */
-  else if (ts.type == BT_CLASS
-	   && !trans_scalar_class_assign (&block, lse, rse))
+  else if (ts.type == BT_CLASS)
     {
       gfc_add_block_to_block (&block, &lse->pre);
       gfc_add_block_to_block (&block, &rse->pre);
-      /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
-	 for the lhs which ensures that class data rhs cast as a string assigns
-	 correctly.  */
-      tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
-			     TREE_TYPE (rse->expr), lse->expr);
-      gfc_add_modify (&block, tmp, rse->expr);
+
+      if (!trans_scalar_class_assign (&block, lse, rse))
+	{
+	  /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
+	  for the lhs which ensures that class data rhs cast as a string assigns
+	  correctly.  */
+	  tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+				 TREE_TYPE (rse->expr), lse->expr);
+	  gfc_add_modify (&block, tmp, rse->expr);
+	}
     }
   else if (ts.type != BT_CLASS)
     {
-- 
cgit v1.1


From b020cee5af4cb40b9971bfb943d7bd2795b2a3eb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jos=C3=A9=20Rui=20Faustino=20de=20Sousa?=
 <jrfsousa@gmail.com>
Date: Wed, 28 Apr 2021 11:20:25 +0000
Subject: Fortran: Fix double function call with -fcheck=pointer [PR]

gcc/fortran/ChangeLog:

	PR fortran/82376
	* trans-expr.c (gfc_conv_procedure_call): Evaluate function result
	and then pass a pointer.

gcc/testsuite/ChangeLog:

	PR fortran/82376
	* gfortran.dg/PR82376.f90: New test.
---
 gcc/fortran/trans-expr.c | 7 ++-----
 1 file changed, 2 insertions(+), 5 deletions(-)

(limited to 'gcc/fortran/trans-expr.c')

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 213f32b..b83b021 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6014,11 +6014,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 			    || (!e->value.function.esym
 				&& e->symtree->n.sym->attr.pointer))
 			&& fsym && fsym->attr.target)
-		{
-		  gfc_conv_expr (&parmse, e);
-		  parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
-		}
-
+		/* Make sure the function only gets called once.  */
+		gfc_conv_expr_reference (&parmse, e, false);
 	      else if (e->expr_type == EXPR_FUNCTION
 		       && e->symtree->n.sym->result
 		       && e->symtree->n.sym->result != e->symtree->n.sym
-- 
cgit v1.1


From a8b79cc939d6786293f654c42a2d1b0ab040de0e Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Wed, 5 May 2021 15:25:50 +0200
Subject: PR fortran/100274 - ICE in gfc_conv_procedure_call, at
 fortran/trans-expr.c:6131

When the check for the length of formal and actual character arguments
found a mismatch and emitted a warning, it would skip further checks
like that could lead to errors.  Fix that by continuing the checking.
Also catch a NULL pointer dereference.

gcc/fortran/ChangeLog:

	PR fortran/100274
	* interface.c (gfc_compare_actual_formal): Continue checks after
	emitting warning for argument length mismatch.
	* trans-expr.c (gfc_conv_procedure_call): Check for NULL pointer
	dereference.

gcc/testsuite/ChangeLog:

	PR fortran/100274
	* gfortran.dg/argument_checking_25.f90: New test.
---
 gcc/fortran/trans-expr.c | 1 +
 1 file changed, 1 insertion(+)

(limited to 'gcc/fortran/trans-expr.c')

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index b83b021..9389a45 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6125,6 +6125,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		      bool add_clobber;
 		      add_clobber = fsym && fsym->attr.intent == INTENT_OUT
 			&& !fsym->attr.allocatable && !fsym->attr.pointer
+			&& e->symtree && e->symtree->n.sym
 			&& !e->symtree->n.sym->attr.dimension
 			&& !e->symtree->n.sym->attr.pointer
 			&& !e->symtree->n.sym->attr.allocatable
-- 
cgit v1.1


From a2c593009fef1564dbef2237ee71e9fd08f5361e Mon Sep 17 00:00:00 2001
From: Paul Thomas <pault@gcc.gnu.org>
Date: Thu, 6 May 2021 14:41:33 +0100
Subject: Fortran: Assumed and explicit size class arrays [PR46691/99819].

2021-05-06  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran/ChangeLog

	PR fortran/46691
	PR fortran/99819
	* class.c (gfc_build_class_symbol): Remove the error that
	disables assumed size class arrays. Class array types that are
	not deferred shape or assumed rank are given a unique name and
	placed in the procedure namespace.
	* trans-array.c (gfc_trans_g77_array): Obtain the data pointer
	for class arrays.
	(gfc_trans_dummy_array_bias): Suppress the runtime error for
	extent violations in explicit shape class arrays because it
	always fails.
	* trans-expr.c (gfc_conv_procedure_call): Handle assumed size
	class actual arguments passed to non-descriptor formal args by
	using the data pointer, stored as the symbol's backend decl.

gcc/testsuite/ChangeLog

	PR fortran/46691
	PR fortran/99819
	* gfortran.dg/class_dummy_6.f90: New test.
	* gfortran.dg/class_dummy_7.f90: New test.
---
 gcc/fortran/trans-expr.c | 9 +++++++++
 1 file changed, 9 insertions(+)

(limited to 'gcc/fortran/trans-expr.c')

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9389a45..7e3de41 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6418,6 +6418,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				fsym ? fsym->attr.intent : INTENT_INOUT,
 				fsym && fsym->attr.pointer);
 
+	      else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
+		       && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
+		       && nodesc_arg && fsym->ts.type == BT_DERIVED)
+		/* An assumed size class actual argument being passed to
+		   a 'no descriptor' formal argument just requires the
+		   data pointer to be passed. For class dummy arguments
+		   this is stored in the symbol backend decl..  */
+		parmse.expr = e->symtree->n.sym->backend_decl;
+
 	      else if (gfc_is_class_array_ref (e, NULL)
 		       && fsym && fsym->ts.type == BT_DERIVED)
 		/* The actual argument is a component reference to an
-- 
cgit v1.1


From 6ba3079dce89d9b63bf5dbd5e320ea2bf96f196b Mon Sep 17 00:00:00 2001
From: Martin Liska <mliska@suse.cz>
Date: Wed, 17 Mar 2021 16:36:44 +0100
Subject: Come up with startswith function.

gcc/ada/ChangeLog:

	* gcc-interface/utils.c (def_builtin_1): Use startswith
	function instead of strncmp.

gcc/analyzer/ChangeLog:

	* sm-file.cc (is_file_using_fn_p): Use startswith
	function instead of strncmp.

gcc/ChangeLog:

	* builtins.c (is_builtin_name): Use startswith
	function instead of strncmp.
	* collect2.c (main): Likewise.
	(has_lto_section): Likewise.
	(scan_libraries): Likewise.
	* coverage.c (coverage_checksum_string): Likewise.
	(coverage_init): Likewise.
	* dwarf2out.c (is_cxx): Likewise.
	(gen_compile_unit_die): Likewise.
	* gcc-ar.c (main): Likewise.
	* gcc.c (init_spec): Likewise.
	(read_specs): Likewise.
	(execute): Likewise.
	(check_live_switch): Likewise.
	* genattrtab.c (write_attr_case): Likewise.
	(IS_ATTR_GROUP): Likewise.
	* gencfn-macros.c (main): Likewise.
	* gengtype.c (type_for_name): Likewise.
	(gen_rtx_next): Likewise.
	(get_file_langdir): Likewise.
	(write_local): Likewise.
	* genmatch.c (get_operator): Likewise.
	(get_operand_type): Likewise.
	(expr::gen_transform): Likewise.
	* genoutput.c (validate_optab_operands): Likewise.
	* incpath.c (add_sysroot_to_chain): Likewise.
	* langhooks.c (lang_GNU_C): Likewise.
	(lang_GNU_CXX): Likewise.
	(lang_GNU_Fortran): Likewise.
	(lang_GNU_OBJC): Likewise.
	* lto-wrapper.c (run_gcc): Likewise.
	* omp-general.c (omp_max_simt_vf): Likewise.
	* omp-low.c (omp_runtime_api_call): Likewise.
	* opts-common.c (parse_options_from_collect_gcc_options): Likewise.
	* read-rtl-function.c (function_reader::read_rtx_operand_r): Likewise.
	* real.c (real_from_string): Likewise.
	* selftest.c (assert_str_startswith): Likewise.
	* timevar.c (timer::validate_phases): Likewise.
	* tree.c (get_file_function_name): Likewise.
	* ubsan.c (ubsan_use_new_style_p): Likewise.
	* varasm.c (default_function_rodata_section): Likewise.
	(incorporeal_function_p): Likewise.
	(default_section_type_flags): Likewise.
	* system.h (startswith): Define startswith.

gcc/c-family/ChangeLog:

	* c-ada-spec.c (print_destructor): Use startswith
	function instead of strncmp.
	(dump_ada_declaration): Likewise.
	* c-common.c (disable_builtin_function): Likewise.
	(def_builtin_1): Likewise.
	* c-format.c (check_tokens): Likewise.
	(check_plain): Likewise.
	(convert_format_name_to_system_name): Likewise.

gcc/c/ChangeLog:

	* c-aux-info.c (affix_data_type): Use startswith
	function instead of strncmp.
	* c-typeck.c (build_function_call_vec): Likewise.
	* gimple-parser.c (c_parser_gimple_parse_bb_spec): Likewise.

gcc/cp/ChangeLog:

	* decl.c (duplicate_decls): Use startswith
	function instead of strncmp.
	(cxx_builtin_function): Likewise.
	(omp_declare_variant_finalize_one): Likewise.
	(grokfndecl): Likewise.
	* error.c (dump_decl_name): Likewise.
	* mangle.c (find_decomp_unqualified_name): Likewise.
	(write_guarded_var_name): Likewise.
	(decl_tls_wrapper_p): Likewise.
	* parser.c (cp_parser_simple_type_specifier): Likewise.
	(cp_parser_tx_qualifier_opt): Likewise.
	* pt.c (template_parm_object_p): Likewise.
	(dguide_name_p): Likewise.

gcc/d/ChangeLog:

	* d-builtins.cc (do_build_builtin_fn): Use startswith
	function instead of strncmp.
	* dmd/dinterpret.c (evaluateIfBuiltin): Likewise.
	* dmd/dmangle.c: Likewise.
	* dmd/hdrgen.c: Likewise.
	* dmd/identifier.c (Identifier::toHChars2): Likewise.

gcc/fortran/ChangeLog:

	* decl.c (variable_decl): Use startswith
	function instead of strncmp.
	(gfc_match_end): Likewise.
	* gfortran.h (gfc_str_startswith): Likewise.
	* module.c (load_omp_udrs): Likewise.
	(read_module): Likewise.
	* options.c (gfc_handle_runtime_check_option): Likewise.
	* primary.c (match_arg_list_function): Likewise.
	* trans-decl.c (gfc_get_symbol_decl): Likewise.
	* trans-expr.c (gfc_conv_procedure_call): Likewise.
	* trans-intrinsic.c (gfc_conv_ieee_arithmetic_function): Likewise.

gcc/go/ChangeLog:

	* gofrontend/runtime.cc (Runtime::name_to_code): Use startswith
	function instead of strncmp.

gcc/objc/ChangeLog:

	* objc-act.c (objc_string_ref_type_p): Use startswith
	function instead of strncmp.
	* objc-encoding.c (encode_type): Likewise.
	* objc-next-runtime-abi-02.c (has_load_impl): Likewise.
---
 gcc/fortran/trans-expr.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'gcc/fortran/trans-expr.c')

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7e3de41..cce18d0 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6847,7 +6847,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       /* When calling __copy for character expressions to unlimited
 	 polymorphic entities, the dst argument needs a string length.  */
       if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
-	  && gfc_str_startswith (sym->name, "__vtab_CHARACTER")
+	  && startswith (sym->name, "__vtab_CHARACTER")
 	  && arg->next && arg->next->expr
 	  && (arg->next->expr->ts.type == BT_DERIVED
 	      || arg->next->expr->ts.type == BT_CLASS)
-- 
cgit v1.1


From fe03f4fc9548b3fdbff3c8284a994feaa7d6307d Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Sun, 23 May 2021 20:51:14 +0200
Subject: Fortran: fix passing return value to class(*) dummy argument

gcc/fortran/ChangeLog:

	PR fortran/100551
	* trans-expr.c (gfc_conv_procedure_call): Adjust check for
	implicit conversion of actual argument to an unlimited polymorphic
	procedure argument.

gcc/testsuite/ChangeLog:

	PR fortran/100551
	* gfortran.dg/pr100551.f90: New test.
---
 gcc/fortran/trans-expr.c | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

(limited to 'gcc/fortran/trans-expr.c')

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index cce18d0..3432cd4 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5826,7 +5826,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				     &derived_array);
 	}
       else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
-	       && gfc_expr_attr (e).flavor != FL_PROCEDURE)
+	       && e->ts.type != BT_PROCEDURE
+	       && (gfc_expr_attr (e).flavor != FL_PROCEDURE
+		   || gfc_expr_attr (e).proc != PROC_UNKNOWN))
 	{
 	  /* The intrinsic type needs to be converted to a temporary
 	     CLASS object for the unlimited polymorphic formal.  */
-- 
cgit v1.1


From 0e3b3b77e13cac764a135a7118613c47686e0a62 Mon Sep 17 00:00:00 2001
From: Tobias Burnus <tobias@codesourcery.com>
Date: Mon, 24 May 2021 16:50:51 +0200
Subject: OpenMP/Fortran: Handle polymorphic scalars in data-sharing
 FIRSTPRIVATE [PR86470]

gcc/fortran/ChangeLog:

	PR fortran/86470
	* trans-expr.c (gfc_copy_class_to_class): Add unshare_expr.
	* trans-openmp.c (gfc_is_polymorphic_nonptr,
	gfc_is_unlimited_polymorphic_nonptr): New.
	(gfc_omp_clause_copy_ctor, gfc_omp_clause_dtor): Handle
	polymorphic scalars.

libgomp/ChangeLog:

	PR fortran/86470
	* testsuite/libgomp.fortran/class-firstprivate-1.f90: New test.
	* testsuite/libgomp.fortran/class-firstprivate-2.f90: New test.
	* testsuite/libgomp.fortran/class-firstprivate-3.f90: New test.

gcc/testsuite/ChangeLog:

	PR fortran/86470
	* gfortran.dg/gomp/class-firstprivate-1.f90: New test.
	* gfortran.dg/gomp/class-firstprivate-2.f90: New test.
	* gfortran.dg/gomp/class-firstprivate-3.f90: New test.
	* gfortran.dg/gomp/class-firstprivate-4.f90: New test.
---
 gcc/fortran/trans-expr.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'gcc/fortran/trans-expr.c')

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 3432cd4..00690fe 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1561,7 +1561,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
 	{
 	  vec_safe_push (args, from_len);
 	  vec_safe_push (args, to_len);
-	  extcopy = build_call_vec (fcn_type, fcn, args);
+	  extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
 	  tmp = fold_build2_loc (input_location, GT_EXPR,
 				 logical_type_node, from_len,
 				 build_zero_cst (TREE_TYPE (from_len)));
-- 
cgit v1.1


From d514626ee2566c68b8a79c7b99aaf791d69e1b2f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jos=C3=A9=20Rui=20Faustino=20de=20Sousa?=
 <jrfsousa@gmail.com>
Date: Sat, 5 Jun 2021 11:12:50 +0000
Subject: Fortran: Fix some issues with pointers to character.

gcc/fortran/ChangeLog:

	PR fortran/100120
	PR fortran/100816
	PR fortran/100818
	PR fortran/100819
	PR fortran/100821
	* trans-array.c (gfc_get_array_span): rework the way character
	array "span" was calculated.
	(gfc_conv_expr_descriptor): improve handling of character sections
	and unlimited polymorphic objects.
	* trans-expr.c (gfc_get_character_len): new function to calculate
	character string length.
	(gfc_get_character_len_in_bytes): new function to calculate
	character string length in bytes.
	(gfc_conv_scalar_to_descriptor): add call to set the "span".
	(gfc_trans_pointer_assignment): set "_len" and antecipate the
	initialization of the deferred character length hidden argument.
	* trans-intrinsic.c (gfc_conv_associated): set "force_no_tmp" to
	avoid the creation of a temporary.
	* trans-types.c (gfc_get_dtype_rank_type): rework type detection
	so that unlimited polymorphic objects get proper type infomation,
	also important for bind(c).
	(gfc_get_dtype): add argument to pass the rank if necessary.
	(gfc_get_array_type_bounds): cosmetic change to have character
	arrays called character instead of unknown.
	* trans-types.h (gfc_get_dtype): modify prototype.
	* trans.c (get_array_span): rework the way character array "span"
	was calculated.
	* trans.h (gfc_get_character_len): new prototype.
	(gfc_get_character_len_in_bytes): new prototype.
	Add "unlimited_polymorphic" flag to "gfc_se" type to signal when
	expression carries an unlimited polymorphic object.

libgfortran/ChangeLog:

	PR fortran/100120
	* intrinsics/associated.c (associated): have associated verify if
	the "span" matches insted of the "elem_len".
	* libgfortran.h (GFC_DESCRIPTOR_SPAN): add macro to retrive the
	descriptor "span".

gcc/testsuite/ChangeLog:

	PR fortran/100120
	* gfortran.dg/PR100120.f90: New test.
	PR fortran/100816
	PR fortran/100818
	PR fortran/100819
	PR fortran/100821
	* gfortran.dg/character_workout_1.f90: New test.
	* gfortran.dg/character_workout_4.f90: New test.
---
 gcc/fortran/trans-expr.c | 70 ++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 56 insertions(+), 14 deletions(-)

(limited to 'gcc/fortran/trans-expr.c')

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 00690fe..e3bc886 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -42,6 +42,45 @@ along with GCC; see the file COPYING3.  If not see
 #include "dependency.h"
 #include "gimplify.h"
 
+
+/* Calculate the number of characters in a string.  */
+
+tree
+gfc_get_character_len (tree type)
+{
+  tree len;
+  
+  gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
+	      && TYPE_STRING_FLAG (type));
+  
+  len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+  len = (len) ? (len) : (integer_zero_node);
+  return fold_convert (gfc_charlen_type_node, len);
+}
+
+
+
+/* Calculate the number of bytes in a string.  */
+
+tree
+gfc_get_character_len_in_bytes (tree type)
+{
+  tree tmp, len;
+  
+  gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
+	      && TYPE_STRING_FLAG (type));
+  
+  tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
+  tmp = (tmp && !integer_zerop (tmp))
+    ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
+  len = gfc_get_character_len (type);
+  if (tmp && len && !integer_zerop (len))
+    len = fold_build2_loc (input_location, MULT_EXPR,
+			   gfc_charlen_type_node, len, tmp);
+  return len;
+}
+
+
 /* Convert a scalar to an array descriptor. To be used for assumed-rank
    arrays.  */
 
@@ -87,6 +126,8 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
   gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
 		  gfc_get_dtype_rank_type (0, etype));
   gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
+  gfc_conv_descriptor_span_set (&se->pre, desc,
+				gfc_conv_descriptor_elem_len (desc));
 
   /* Copy pointer address back - but only if it could have changed and
      if the actual argument is a pointer and not, e.g., NULL().  */
@@ -9630,11 +9671,12 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  lse.direct_byref = 1;
 	  gfc_conv_expr_descriptor (&lse, expr2);
 	  strlen_rhs = lse.string_length;
+	  gfc_init_se (&rse, NULL);
 
 	  if (expr1->ts.type == BT_CLASS)
 	    {
 	      rse.expr = NULL_TREE;
-	      rse.string_length = NULL_TREE;
+	      rse.string_length = strlen_rhs;
 	      trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
 					       NULL, NULL);
 	    }
@@ -9694,6 +9736,19 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  gfc_add_modify (&lse.pre, desc, tmp);
 	}
 
+      if (expr1->ts.type == BT_CHARACTER
+	  && expr1->symtree->n.sym->ts.deferred
+	  && expr1->symtree->n.sym->ts.u.cl->backend_decl
+	  && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
+	{
+	  tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
+	  if (expr2->expr_type != EXPR_NULL)
+	    gfc_add_modify (&block, tmp,
+			    fold_convert (TREE_TYPE (tmp), strlen_rhs));
+	  else
+	    gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
+	}
+
       gfc_add_block_to_block (&block, &lse.pre);
       if (rank_remap)
 	gfc_add_block_to_block (&block, &rse.pre);
@@ -9856,19 +9911,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 				   msg, rsize, lsize);
 	}
 
-      if (expr1->ts.type == BT_CHARACTER
-	  && expr1->symtree->n.sym->ts.deferred
-	  && expr1->symtree->n.sym->ts.u.cl->backend_decl
-	  && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
-	{
-	  tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
-	  if (expr2->expr_type != EXPR_NULL)
-	    gfc_add_modify (&block, tmp,
-			    fold_convert (TREE_TYPE (tmp), strlen_rhs));
-	  else
-	    gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
-	}
-
       /* Check string lengths if applicable.  The check is only really added
 	 to the output code if -fbounds-check is enabled.  */
       if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
-- 
cgit v1.1


From 48aa5c60034736a439f2214dac34b165e74a7d20 Mon Sep 17 00:00:00 2001
From: Martin Liska <mliska@suse.cz>
Date: Tue, 8 Jun 2021 09:42:18 +0200
Subject: Fix "tailing" typo.

gcc/fortran/ChangeLog:

	* intrinsic.texi: Fix typo.
	* trans-expr.c (gfc_trans_pointer_assignment): Likewise.

gcc/ChangeLog:

	* genautomata.c (create_automata): Fix typo.

libgfortran/ChangeLog:

	* intrinsics/chmod.c (chmod_internal): Fix typo.
	* io/transfer.c (read_sf): Likewise.

libquadmath/ChangeLog:

	* libquadmath.texi: Fix typo.

gcc/testsuite/ChangeLog:

	* gcc.dg/format/strfmon-1.c: Fix typo.
	* gfortran.dg/char4-subscript.f90: Likewise.
---
 gcc/fortran/trans-expr.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'gcc/fortran/trans-expr.c')

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e3bc886..de406ad 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -9513,7 +9513,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
     {
       gfc_add_data_component (expr2);
       /* The following is required as gfc_add_data_component doesn't
-	 update ts.type if there is a tailing REF_ARRAY.  */
+	 update ts.type if there is a trailing REF_ARRAY.  */
       expr2->ts.type = BT_DERIVED;
     }
 
-- 
cgit v1.1


From 269ca408e2839d7f3554a91515d73d4d95352f68 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Wed, 14 Jul 2021 17:25:29 +0200
Subject: Fortran - ICE in gfc_conv_expr_present initializing non-dummy class
 variable

gcc/fortran/ChangeLog:

	PR fortran/100949
	* trans-expr.c (gfc_trans_class_init_assign): Call
	gfc_conv_expr_present only for dummy variables.

gcc/testsuite/ChangeLog:

	PR fortran/100949
	* gfortran.dg/pr100949.f90: New test.
---
 gcc/fortran/trans-expr.c | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

(limited to 'gcc/fortran/trans-expr.c')

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index de406ad..9e0dcde 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1741,8 +1741,9 @@ gfc_trans_class_init_assign (gfc_code *code)
 	}
     }
 
-  if (code->expr1->symtree->n.sym->attr.optional
-      || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)
+  if (code->expr1->symtree->n.sym->attr.dummy
+      && (code->expr1->symtree->n.sym->attr.optional
+	  || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
     {
       tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
       tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
-- 
cgit v1.1


From b3d4011ba10275fbd5d6ec5a16d5aaebbdfb5d3c Mon Sep 17 00:00:00 2001
From: Tobias Burnus <tobias@codesourcery.com>
Date: Wed, 21 Jul 2021 09:36:48 +0200
Subject: Fortran: Fix bind(C) character length checks

gcc/fortran/ChangeLog:

	* decl.c (gfc_verify_c_interop_param): Update for F2008 + F2018
	changes; reject unsupported bits with 'Error: Sorry,'.
	* trans-expr.c (gfc_conv_procedure_call): Fix condition to
	For using CFI descriptor with characters.

gcc/testsuite/ChangeLog:

	* gfortran.dg/iso_c_binding_char_1.f90: Update dg-error.
	* gfortran.dg/pr32599.f03: Use -std=-f2003 + update comment.
	* gfortran.dg/bind_c_char_10.f90: New test.
	* gfortran.dg/bind_c_char_6.f90: New test.
	* gfortran.dg/bind_c_char_7.f90: New test.
	* gfortran.dg/bind_c_char_8.f90: New test.
	* gfortran.dg/bind_c_char_9.f90: New test.
---
 gcc/fortran/trans-expr.c | 18 ++++++++----------
 1 file changed, 8 insertions(+), 10 deletions(-)

(limited to 'gcc/fortran/trans-expr.c')

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9e0dcde..b18a9ec 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5757,18 +5757,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
        arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
     {
       bool finalized = false;
-      bool non_unity_length_string = false;
+      bool assumed_length_string = false;
       tree derived_array = NULL_TREE;
 
       e = arg->expr;
       fsym = formal ? formal->sym : NULL;
       parm_kind = MISSING;
 
-      if (fsym && fsym->ts.type == BT_CHARACTER && fsym->ts.u.cl
-	  && (!fsym->ts.u.cl->length
-	      || fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT
-	      || mpz_cmp_si (fsym->ts.u.cl->length->value.integer, 1) != 0))
-	non_unity_length_string = true;
+      if (fsym && fsym->ts.type == BT_CHARACTER
+	  && (!fsym->ts.u.cl || !fsym->ts.u.cl->length))
+	assumed_length_string = true;
 
       /* If the procedure requires an explicit interface, the actual
 	 argument is passed according to the corresponding formal
@@ -6002,8 +6000,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
 	      else if (sym->attr.is_bind_c && e
 		       && (is_CFI_desc (fsym, NULL)
-			   || non_unity_length_string))
-		/* Implement F2018, C.12.6.1: paragraph (2).  */
+			   || assumed_length_string))
+		/* Implement F2018, 18.3.6, list item (5), bullet point 2.  */
 		gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
 
 	      else if (fsym && fsym->attr.value)
@@ -6447,8 +6445,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		}
 
 	      if (sym->attr.is_bind_c && e
-		  && (is_CFI_desc (fsym, NULL) || non_unity_length_string))
-		/* Implement F2018, C.12.6.1: paragraph (2).  */
+		  && (is_CFI_desc (fsym, NULL) || assumed_length_string))
+		/* Implement F2018, 18.3.6, list item (5), bullet point 2.  */
 		gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
 
 	      else if (e->expr_type == EXPR_VARIABLE
-- 
cgit v1.1


From 0cbf03689e3e7d9d6002b8e5d159ef3716d0404c Mon Sep 17 00:00:00 2001
From: Tobias Burnus <tobias@codesourcery.com>
Date: Mon, 26 Jul 2021 14:20:46 +0200
Subject: PR fortran/93308/93963/94327/94331/97046 problems raised by
 descriptor handling
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Fortran: Fix attributes and bounds in ISO_Fortran_binding.

2021-07-26  José Rui Faustino de Sousa  <jrfsousa@gmail.com>
	    Tobias Burnus  <tobias@codesourcery.com>

	PR fortran/93308
	PR fortran/93963
	PR fortran/94327
	PR fortran/94331
	PR fortran/97046

gcc/fortran/ChangeLog:

	* trans-decl.c (convert_CFI_desc): Only copy out the descriptor
	if necessary.
	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Updated attribute
	handling which reflect a previous intermediate version of the
	standard. Only copy out the descriptor if necessary.

libgfortran/ChangeLog:

	* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Add code
	to verify the descriptor. Correct bounds calculation.
	(gfc_desc_to_cfi_desc): Add code to verify the descriptor.

gcc/testsuite/ChangeLog:

	* gfortran.dg/ISO_Fortran_binding_1.f90: Add pointer attribute,
	this test is still erroneous but now it compiles.
	* gfortran.dg/bind_c_array_params_2.f90: Update regex to match
	code changes.
	* gfortran.dg/PR93308.f90: New test.
	* gfortran.dg/PR93963.f90: New test.
	* gfortran.dg/PR94327.c: New test.
	* gfortran.dg/PR94327.f90: New test.
	* gfortran.dg/PR94331.c: New test.
	* gfortran.dg/PR94331.f90: New test.
	* gfortran.dg/PR97046.f90: New test.
---
 gcc/fortran/trans-expr.c | 24 ++++++++++++++----------
 1 file changed, 14 insertions(+), 10 deletions(-)

(limited to 'gcc/fortran/trans-expr.c')

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index b18a9ec..c4291cc 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5502,13 +5502,12 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
 	attribute = 1;
     }
 
-  /* If the formal argument is assumed shape and neither a pointer nor
-     allocatable, it is unconditionally CFI_attribute_other.  */
-  if (fsym->as->type == AS_ASSUMED_SHAPE
-      && !fsym->attr.pointer && !fsym->attr.allocatable)
-   cfi_attribute = 2;
+  if (fsym->attr.pointer)
+    cfi_attribute = 0;
+  else if (fsym->attr.allocatable)
+    cfi_attribute = 1;
   else
-   cfi_attribute = attribute;
+    cfi_attribute = 2;
 
   if (e->rank != 0)
     {
@@ -5616,10 +5615,15 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
   gfc_prepend_expr_to_block (&parmse->post, tmp);
 
   /* Transfer values back to gfc descriptor.  */
-  tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
-  tmp = build_call_expr_loc (input_location,
-			     gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
-  gfc_prepend_expr_to_block (&parmse->post, tmp);
+  if (cfi_attribute != 2  /* CFI_attribute_other.  */
+      && !fsym->attr.value
+      && fsym->attr.intent != INTENT_IN)
+    {
+      tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+      tmp = build_call_expr_loc (input_location,
+				 gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
+      gfc_prepend_expr_to_block (&parmse->post, tmp);
+    }
 
   /* Deal with an optional dummy being passed to an optional formal arg
      by finishing the pre and post blocks and making their execution
-- 
cgit v1.1


From 5fe0865ab788bdc387b284a3ad57e5a95a767b18 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Thu, 9 Sep 2021 21:34:01 +0200
Subject: Fortran - out of bounds in array constructor with implied do loop

gcc/fortran/ChangeLog:

	PR fortran/98490
	* trans-expr.c (gfc_conv_substring): Do not generate substring
	bounds check for implied do loop index variable before it actually
	becomes defined.

gcc/testsuite/ChangeLog:

	PR fortran/98490
	* gfortran.dg/bounds_check_23.f90: New test.
---
 gcc/fortran/trans-expr.c | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

(limited to 'gcc/fortran/trans-expr.c')

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index c4291cc..18d6651 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2630,7 +2630,9 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
   if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
     end.expr = gfc_evaluate_now (end.expr, &se->pre);
 
-  if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+  if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+      && (ref->u.ss.start->symtree
+	  && !ref->u.ss.start->symtree->n.sym->attr.implied_index))
     {
       tree nonempty = fold_build2_loc (input_location, LE_EXPR,
 				       logical_type_node, start.expr,
-- 
cgit v1.1