re PR fortran/92004 (Rejection of different ranks for dummy array argument where...
authorThomas Koenig <tkoenig@gcc.gnu.org>
Mon, 14 Oct 2019 21:37:34 +0000 (21:37 +0000)
committerThomas Koenig <tkoenig@gcc.gnu.org>
Mon, 14 Oct 2019 21:37:34 +0000 (21:37 +0000)
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
gcc/fortran/array.c
gcc/fortran/gfortran.h
gcc/fortran/interface.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/abstract_type_6.f03
gcc/testsuite/gfortran.dg/argument_checking_11.f90
gcc/testsuite/gfortran.dg/argument_checking_13.f90
gcc/testsuite/gfortran.dg/argument_checking_24.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/interface_40.f90

index 1f119a84569155a1a1cd1dab2dc02aac0f179a7d..7e05e9105aa6959771e5253fc1ae770f2a067890 100644 (file)
@@ -1,3 +1,19 @@
+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.
index cbeece44ecf3f11185b2034c4364063c87e63d35..427110bee74de329dda8a94679036fdfd16b44f2 100644 (file)
@@ -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;
index d84d1fa7f7e1581c38c2e22d197ca0c4613e102b..920acdafc6b79b5de56be16a1d0c77f0c939d4c5 100644 (file)
@@ -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
index 3313e729db9f77e9350eebd5373455cca8651906..919c95a87c80d42e4601bf71789d97fcbb2a4f2d 100644 (file)
@@ -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;
index 494c67f9b19faaf1d6b96840551cb707c617083a..0f4eb9f45c078f68d93a10f03be8fb556fa95e25 100644 (file)
@@ -1,3 +1,13 @@
+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.
index 9dd0a37c56454cdcacf93ec15c13bbbdefd34f96..ebef02ed82a854c1bb0a965d358f395ee28d6bb2 100644 (file)
@@ -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
index 7c70c37ee47b0de1de2205ee8c51c8664f155cb7..43364a6d5c537cf6b3005036019b890fbd9a9e4b 100644 (file)
@@ -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" }
index 26e9497f1b114132e6d6f49568c0b0ffa4649c91..1b7f0c646db352c0cc3b2cf72ce78801cb33dd54 100644 (file)
@@ -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)
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_24.f90 b/gcc/testsuite/gfortran.dg/argument_checking_24.f90
new file mode 100644 (file)
index 0000000..a5f3abe
--- /dev/null
@@ -0,0 +1,63 @@
+! { 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
index 085c6b30f3946ec5681d26343352fb0e447cce12..68a10c8dd5d0c5a198d4abd2085145c599b6d315 100644 (file)
@@ -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