re PR fortran/92004 (Rejection of different ranks for dummy array argument where…

re PR fortran/92004 (Rejection of different ranks for dummy array argument where actual argument is an element)

2019-10-14  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/92004
	* array.c (expand_constructor): Set from_constructor on
	expression.
	* gfortran.h (gfc_symbol): Add maybe_array.
	(gfc_expr): Add from_constructor.
	* interface.c (maybe_dummy_array_arg): New function.
	(compare_parameter): If the formal argument is generated from a
	call, check the conditions where an array element could be
	passed to an array.  Adjust error message for assumed-shape
	or pointer array.  Use correct language for assumed shaped arrays.
	(gfc_get_formal_from_actual_arglist): Set maybe_array on the
	symbol if the actual argument is an array element fulfilling
	the conditions of 15.5.2.4.

2019-10-14  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/92004
	* gfortran.dg/argument_checking_24.f90: New test.
	* gfortran.dg/abstract_type_6.f90: Add error message.
	* gfortran.dg/argument_checking_11.f90: Correct wording
	in error message.
	* gfortran.dg/argumeent_checking_13.f90: Likewise.
	* gfortran.dg/interface_40.f90: Add error message.

From-SVN: r276972

gcc/fortran/ChangeLog

+2019-10-14  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/92004
+	* array.c (expand_constructor): Set from_constructor on
+	expression.
+	* gfortran.h (gfc_symbol): Add maybe_array.
+	(gfc_expr): Add from_constructor.
+	* interface.c (maybe_dummy_array_arg): New function.
+	(compare_parameter): If the formal argument is generated from a
+	call, check the conditions where an array element could be
+	passed to an array.  Adjust error message for assumed-shape
+	or pointer array.  Use correct language for assumed shaped arrays.
+	(gfc_get_formal_from_actual_arglist): Set maybe_array on the
+	symbol if the actual argument is an array element fulfilling
+	the conditions of 15.5.2.4.
+
 2019-10-14  Tobias Burnus  <tobias@codesourcery.com>
 
 	* error.c: Remove debug pragma added in previous commit.

gcc/fortran/array.c

@@ -1782,6 +1782,7 @@ expand_constructor (gfc_constructor_base base)
 	  gfc_free_expr (e);
 	  return false;
 	}
+      e->from_constructor = 1;
       current_expand.offset = &c->offset;
       current_expand.repeat = &c->repeat;
       current_expand.component = c->n.component;

gcc/fortran/gfortran.h

@@ -1614,6 +1614,9 @@ typedef struct gfc_symbol
   /* Set if a previous error or warning has occurred and no other
      should be reported.  */
   unsigned error:1;
+  /* Set if the dummy argument of a procedure could be an array despite
+     being called with a scalar actual argument. */
+  unsigned maybe_array:1;
 
   int refs;
   struct gfc_namespace *ns;	/* namespace containing this symbol */
@@ -2194,6 +2197,10 @@ typedef struct gfc_expr
   /* Set this if no warning should be given somewhere in a lower level.  */
 
   unsigned int do_not_warn : 1;
+
+  /* Set this if the expression came from expanding an array constructor.  */
+  unsigned int from_constructor : 1;
+
   /* If an expression comes from a Hollerith constant or compile-time
      evaluation of a transfer statement, it may have a prescribed target-
      memory representation, and these cannot always be backformed from

gcc/fortran/interface.c

@@ -2229,6 +2229,67 @@ argument_rank_mismatch (const char *name, locus *where,
 }
 
 
+/* Under certain conditions, a scalar actual argument can be passed
+   to an array dummy argument - see F2018, 15.5.2.4, paragraph 14.
+   This function returns true for these conditions so that an error
+   or warning for this can be suppressed later.  Always return false
+   for expressions with rank > 0.  */
+
+bool
+maybe_dummy_array_arg (gfc_expr *e)
+{
+  gfc_symbol *s;
+  gfc_ref *ref;
+  bool array_pointer = false;
+  bool assumed_shape = false;
+  bool scalar_ref = true;
+
+  if (e->rank > 0)
+    return false;
+
+  if (e->ts.type == BT_CHARACTER && e->ts.kind == 1)
+    return true;
+
+  /* If this comes from a constructor, it has been an array element
+     originally.  */
+
+  if (e->expr_type == EXPR_CONSTANT)
+    return e->from_constructor;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  s = e->symtree->n.sym;
+
+  if (s->attr.dimension)
+    {
+      scalar_ref = false;
+      array_pointer = s->attr.pointer;
+    }
+
+  if (s->as && s->as->type == AS_ASSUMED_SHAPE)
+    assumed_shape = true;
+
+  for (ref=e->ref; ref; ref=ref->next)
+    {
+      if (ref->type == REF_COMPONENT)
+	{
+	  symbol_attribute *attr;
+	  attr = &ref->u.c.component->attr;
+	  if (attr->dimension)
+	    {
+	      array_pointer = attr->pointer;
+	      assumed_shape = false;
+	      scalar_ref = false;
+	    }
+	  else
+	    scalar_ref = true;
+	}
+    }
+
+  return !(scalar_ref || array_pointer || assumed_shape);
+}
+
 /* Given a symbol of a formal argument list and an expression, see if
    the two are compatible as arguments.  Returns true if
    compatible, false if not compatible.  */
@@ -2544,7 +2605,9 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       || (actual->rank == 0 && formal->attr.dimension
 	  && gfc_is_coindexed (actual)))
     {
-      if (where)
+      if (where 
+	  && (!formal->attr.artificial || (!formal->maybe_array
+					   && !maybe_dummy_array_arg (actual))))
 	{
 	  locus *where_formal;
 	  if (formal->attr.artificial)
@@ -2594,9 +2657,17 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
     {
       if (where)
-	gfc_error ("Element of assumed-shaped or pointer "
-		   "array passed to array dummy argument %qs at %L",
-		   formal->name, &actual->where);
+	{
+	  if (formal->attr.artificial)
+	    gfc_error ("Element of assumed-shape or pointer array "
+		       "as actual argument at %L can not correspond to "
+		       "actual argument at %L ",
+		       &actual->where, &formal->declared_at);
+	  else
+	    gfc_error ("Element of assumed-shape or pointer "
+		       "array passed to array dummy argument %qs at %L",
+		       formal->name, &actual->where);
+	}
       return false;
     }
 
@@ -2625,7 +2696,9 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 
   if (ref == NULL && actual->expr_type != EXPR_NULL)
     {
-      if (where)
+      if (where 
+	  && (!formal->attr.artificial || (!formal->maybe_array
+					   && !maybe_dummy_array_arg (actual))))
 	{
 	  locus *where_formal;
 	  if (formal->attr.artificial)
@@ -3717,6 +3790,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 {
   gfc_actual_arglist *a;
   gfc_formal_arglist *dummy_args;
+  bool implicit = false;
 
   /* Warn about calls with an implicit interface.  Special case
      for calling a ISO_C_BINDING because c_loc and c_funloc
@@ -3724,6 +3798,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
      explicitly declared at all if requested.  */
   if (sym->attr.if_source == IFSRC_UNKNOWN && !sym->attr.is_iso_c)
     {
+      implicit = true;
       if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN)
 	{
 	  const char *guessed
@@ -3778,6 +3853,19 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 	  if (a->expr && a->expr->error)
 	    return false;
 
+	  /* F2018, 15.4.2.2 Explicit interface is required for a
+	     polymorphic dummy argument, so there is no way to
+	     legally have a class appear in an argument with an
+	     implicit interface.  */
+
+	  if (implicit && a->expr && a->expr->ts.type == BT_CLASS)
+	    {
+	      gfc_error ("Explicit interface required for polymorphic "
+			 "argument at %L",&a->expr->where);
+	      a->expr->error = 1;
+	      break;
+	    }
+
 	  /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
 	  if (a->name != NULL && a->name[0] != '%')
 	    {
@@ -5228,6 +5316,8 @@ gfc_get_formal_from_actual_arglist (gfc_symbol *sym,
 		  s->as->upper[0] = NULL;
 		  s->as->type = AS_ASSUMED_SIZE;
 		}
+	      else
+		s->maybe_array = maybe_dummy_array_arg (a->expr);
 	    }
 	  s->attr.dummy = 1;
 	  s->declared_at = a->expr->where;

gcc/testsuite/ChangeLog

+2019-10-14  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/92004
+	* gfortran.dg/argument_checking_24.f90: New test.
+	* gfortran.dg/abstract_type_6.f90: Add error message.
+	* gfortran.dg/argument_checking_11.f90: Correct wording
+	in error message.
+	* gfortran.dg/argumeent_checking_13.f90: Likewise.
+	* gfortran.dg/interface_40.f90: Add error message.
+
 2019-10-14  Maya Rashish  <coypu@sdf.org>
 
 	* gcc.c-torture/compile/pr85401: New test.

gcc/testsuite/gfortran.dg/abstract_type_6.f03

@@ -46,7 +46,7 @@ END SUBROUTINE bottom_b
 
 SUBROUTINE bottom_c(obj)
    CLASS(Bottom) :: obj
-   CALL top_c(obj)
+   CALL top_c(obj) ! { dg-error "Explicit interface required" }
    ! other stuff
 END SUBROUTINE bottom_c 
 end module

gcc/testsuite/gfortran.dg/argument_checking_11.f90

@@ -29,8 +29,8 @@ SUBROUTINE test1(a,b,c,d,e)
  call as_size( (c) ) ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array" }
  call as_size( (d) )
  call as_size( (e) ) ! { dg-error "Rank mismatch" }
- call as_size(a(1)) ! { dg-error "Element of assumed-shaped" }
- call as_size(b(1)) ! { dg-error "Element of assumed-shaped" }
+ call as_size(a(1)) ! { dg-error "Element of assumed-shape" }
+ call as_size(b(1)) ! { dg-error "Element of assumed-shape" }
  call as_size(c(1))
  call as_size(d(1))
  call as_size( (a(1)) ) ! { dg-error "Rank mismatch" }
@@ -89,8 +89,8 @@ SUBROUTINE test1(a,b,c,d,e)
  call as_expl( (c) ) ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array" }
  call as_expl( (d) )
  call as_expl( (e) ) ! { dg-error "Rank mismatch" }
- call as_expl(a(1)) ! { dg-error "Element of assumed-shaped" }
- call as_expl(b(1)) ! { dg-error "Element of assumed-shaped" }
+ call as_expl(a(1)) ! { dg-error "Element of assumed-shape" }
+ call as_expl(b(1)) ! { dg-error "Element of assumed-shape" }
  call as_expl(c(1))
  call as_expl(d(1))
  call as_expl( (a(1)) ) ! { dg-error "Rank mismatch" }

gcc/testsuite/gfortran.dg/argument_checking_13.f90

@@ -26,9 +26,9 @@ real, pointer :: pointer_dummy(:,:,:)
 real, allocatable :: deferred(:,:,:)
 real, pointer     :: ptr(:,:,:)
 call rlv1(deferred(1,1,1))         ! valid since contiguous
-call rlv1(ptr(1,1,1))              ! { dg-error "Element of assumed-shaped or pointer array" }
-call rlv1(assumed_sh_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped or pointer array" }
-call rlv1(pointer_dummy(1,1,1))    ! { dg-error "Element of assumed-shaped or pointer array" }
+call rlv1(ptr(1,1,1))              ! { dg-error "Element of assumed-shape or pointer array" }
+call rlv1(assumed_sh_dummy(1,1,1)) ! { dg-error "Element of assumed-shape or pointer array" }
+call rlv1(pointer_dummy(1,1,1))    ! { dg-error "Element of assumed-shape or pointer array" }
 end
 
 subroutine test2(assumed_sh_dummy, pointer_dummy)

gcc/testsuite/gfortran.dg/argument_checking_24.f90

+! { dg-do compile }
+! PR 92004 - checks in the absence of an explicit interface between
+! array elements and arrays
+module x
+  implicit none
+  type t
+     real :: x
+  end type t
+  type tt
+     real :: x(2)
+  end type tt
+  type pointer_t
+     real, pointer :: x(:)
+  end type pointer_t
+  type alloc_t
+     real, dimension(:), allocatable :: x
+  end type alloc_t
+contains
+  subroutine foo(a)
+    real, dimension(:) :: a
+    real, dimension(2), parameter :: b = [1.0, 2.0]
+    real, dimension(10) :: x
+    type (t), dimension(1) :: vv
+    type (pointer_t) :: pointer_v
+    real, dimension(:), pointer :: p
+    call invalid_1(a(1))  ! { dg-error "Rank mismatch" }
+    call invalid_1(a) ! { dg-error "Rank mismatch" }
+    call invalid_2(a) ! { dg-error "Element of assumed-shape or pointer" }
+    call invalid_2(a(1))  ! { dg-error "Element of assumed-shape or pointer" }
+    call invalid_3(b) ! { dg-error "Rank mismatch" }
+    call invalid_3(1.0) ! { dg-error "Rank mismatch" }
+    call invalid_4 (vv(1)%x) ! { dg-error "Rank mismatch" }
+    call invalid_4 (b) ! { dg-error "Rank mismatch" }w
+    call invalid_5 (b) ! { dg-error "Rank mismatch" }
+    call invalid_5 (vv(1)%x) ! { dg-error "Rank mismatch" }
+    call invalid_6 (x) ! { dg-error "can not correspond to actual argument" }
+    call invalid_6 (pointer_v%x(1)) ! { dg-error "can not correspond to actual argument" }
+    call invalid_7 (pointer_v%x(1)) ! { dg-error "Rank mismatch" }
+    call invalid_7 (x) ! { dg-error "Rank mismatch" }
+    call invalid_8 (p(1)) ! { dg-error "Rank mismatch" }
+    call invalid_8 (x) ! { dg-error "Rank mismatch" }
+    call invalid_9 (x) ! { dg-error "can not correspond to actual argument" }
+    call invalid_9 (p(1)) ! { dg-error "can not correspond to actual argument" }
+  end subroutine foo
+
+  subroutine bar(a, alloc)
+    real, dimension(*) :: a
+    real, dimension(2), parameter :: b = [1.0, 2.0]
+    type (alloc_t), pointer :: alloc
+    type (tt) :: tt_var
+    ! None of the ones below should issue an error.
+    call valid_1 (a)
+    call valid_1 (a(1))
+    call valid_2 (a(1))
+    call valid_2 (a)
+    call valid_3 (b)
+    call valid_3 (b(1))
+    call valid_4 (tt_var%x)
+    call valid_4 (tt_var%x(1))
+    call valid_5 (alloc%x(1))
+    call valid_5 (a)
+  end subroutine bar
+end module x

gcc/testsuite/gfortran.dg/interface_40.f90

@@ -3,6 +3,6 @@
 ! Code contributed by Gerhard Steinmetz
 program p
    class(*) :: x  ! { dg-error " must be dummy, allocatable or pointer" }
-   print *, f(x)
+   print *, f(x) ! { dg-error "Explicit interface required" }
 end