OSDN Git Service

2007-07-03 Tobias Burnus <burnus@net-b.de>
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 3 Jul 2007 19:16:42 +0000 (19:16 +0000)
committerburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 3 Jul 2007 19:16:42 +0000 (19:16 +0000)
PR fortran/30940
* interface.c (get_sym_storage_size): New function.
(get_sym_storage_size): New function.
(compare_actual_formal): Enhance sequence association
support and improve checking.

2007-07-03  Tobias Burnus  <burnus@net-b.de>

PR fortran/30940
* gfortran.dg/argument_checking_1.f90: New.
* gfortran.dg/argument_checking_2.f90: New.
* gfortran.dg/argument_checking_3.f90: New.
* gfortran.dg/argument_checking_4.f90: New.
* gfortran.dg/argument_checking_5.f90: New.
* gfortran.fortran-torture/execute/st_function_1.f90: Add dg-warning.
* gfortran.fortran-torture/execute/st_function.f90: Add dg-warning.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@126271 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/interface.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/argument_checking_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/argument_checking_2.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/argument_checking_3.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/argument_checking_4.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/argument_checking_5.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/char_length_3.f90
gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90
gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90

index 1ee1862..1bd7a50 100644 (file)
@@ -1,3 +1,11 @@
+2007-07-03  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/30940
+       * interface.c (get_sym_storage_size): New function.
+       (get_sym_storage_size): New function.
+       (compare_actual_formal): Enhance sequence association
+       support and improve checking.
+
 2007-07-03  Janne Blomqvist  <jb@gcc.gnu.org>
 
        * trans-decl.c (gfc_build_builtin_function_decls): Mark
index 69ab326..5586494 100644 (file)
@@ -1283,6 +1283,153 @@ compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
 }
 
 
+/* Returns the storage size of a symbol (formal argument) or
+   zero if it cannot be determined.  */
+
+static unsigned long
+get_sym_storage_size (gfc_symbol *sym)
+{
+  int i;
+  unsigned long strlen, elements;
+
+  if (sym->ts.type == BT_CHARACTER)
+    {
+      if (sym->ts.cl && sym->ts.cl->length
+          && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+       strlen = mpz_get_ui (sym->ts.cl->length->value.integer);
+      else
+       return 0;
+    }
+  else
+    strlen = 1; 
+
+  if (symbol_rank (sym) == 0)
+    return strlen;
+
+  elements = 1;
+  if (sym->as->type != AS_EXPLICIT)
+    return 0;
+  for (i = 0; i < sym->as->rank; i++)
+    {
+      if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
+         || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
+       return 0;
+
+      elements *= mpz_get_ui (sym->as->upper[i]->value.integer)
+                 - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L;
+    }
+
+  return strlen*elements;
+}
+
+
+/* Returns the storage size of an expression (actual argument) or
+   zero if it cannot be determined. For an array element, it returns
+   the remaing size as the element sequence consists of all storage
+   units of the actual argument up to the end of the array.  */
+
+static unsigned long
+get_expr_storage_size (gfc_expr *e)
+{
+  int i;
+  long int strlen, elements;
+  gfc_ref *ref;
+
+  if (e == NULL)
+    return 0;
+  
+  if (e->ts.type == BT_CHARACTER)
+    {
+      if (e->ts.cl && e->ts.cl->length
+          && e->ts.cl->length->expr_type == EXPR_CONSTANT)
+       strlen = mpz_get_si (e->ts.cl->length->value.integer);
+      else if (e->expr_type == EXPR_CONSTANT
+              && (e->ts.cl == NULL || e->ts.cl->length == NULL))
+       strlen = e->value.character.length;
+      else
+       return 0;
+    }
+  else
+    strlen = 1; /* Length per element.  */
+
+  if (e->rank == 0 && !e->ref)
+    return strlen;
+
+  elements = 1;
+  if (!e->ref)
+    {
+      if (!e->shape)
+       return 0;
+      for (i = 0; i < e->rank; i++)
+       elements *= mpz_get_si (e->shape[i]);
+      return elements*strlen;
+    }
+
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
+         && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
+         && ref->u.ar.as->upper)
+       for (i = 0; i < ref->u.ar.dimen; i++)
+         {
+           long int start, end, stride;
+           stride = 1;
+           start = 1;
+           if (ref->u.ar.stride[i])
+             {
+               if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
+                 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
+               else
+                 return 0;
+             }
+
+           if (ref->u.ar.start[i])
+             {
+               if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
+                 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
+               else
+                 return 0;
+             }
+
+           if (ref->u.ar.end[i])
+             {
+               if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
+                 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
+               else
+                 return 0;
+             }
+           else if (ref->u.ar.as->upper[i]
+                    && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
+             end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
+           else
+             return 0;
+
+           elements *= (end - start)/stride + 1L;
+         }
+      else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
+              && ref->u.ar.as->lower && ref->u.ar.as->upper)
+       for (i = 0; i < ref->u.ar.as->rank; i++)
+         {
+           if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
+               && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
+               && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
+             elements *= mpz_get_ui (ref->u.ar.as->upper[i]->value.integer)
+                         - mpz_get_ui (ref->u.ar.as->lower[i]->value.integer)
+                         + 1L;
+           else
+             return 0;
+         }
+      else
+        /* TODO: Determine the number of remaining elements in the element
+           sequence for array element designators.
+           See also get_array_index in data.c.  */
+       return 0;
+    }
+
+  return elements*strlen;
+}
+
+
 /* Given an expression, check whether it is an array section
    which has a vector subscript. If it has, one is returned,
    otherwise zero.  */
@@ -1321,6 +1468,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
   gfc_formal_arglist *f;
   int i, n, na;
   bool rank_check;
+  unsigned long actual_size, formal_size;
 
   actual = *ap;
 
@@ -1404,8 +1552,23 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
                   && (f->sym->as->type == AS_ASSUMED_SHAPE
                       || f->sym->as->type == AS_DEFERRED);
 
-      if (!compare_parameter (f->sym, a->expr,
-                             ranks_must_agree || rank_check, is_elemental))
+      if (f->sym->ts.type == BT_CHARACTER && a->expr->ts.type == BT_CHARACTER
+         && a->expr->rank == 0
+         && f->sym->as && f->sym->as->type != AS_ASSUMED_SHAPE)
+       {
+         if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
+           {
+             gfc_error ("Fortran 2003: Scalar CHARACTER actual argument "
+                        "with array dummy argument '%s' at %L",
+                        f->sym->name, &a->expr->where);
+             return 0;
+           }
+         else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
+           return 0;
+
+       }
+      else if (!compare_parameter (f->sym, a->expr,
+                                  ranks_must_agree || rank_check, is_elemental))
        {
          if (where)
            gfc_error ("Type/rank mismatch in argument '%s' at %L",
@@ -1413,34 +1576,42 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
          return 0;
        }
 
-       if (a->expr->ts.type == BT_CHARACTER
+      if (a->expr->ts.type == BT_CHARACTER
           && a->expr->ts.cl && a->expr->ts.cl->length
           && a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
           && f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
           && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT)
         {
-          if (mpz_cmp (a->expr->ts.cl->length->value.integer,
-                       f->sym->ts.cl->length->value.integer) < 0)
-            {
-               if (where)
-                 gfc_error ("Character length of actual argument shorter "
-                            "than of dummy argument '%s' at %L",
-                            f->sym->name, &a->expr->where);
-               return 0;
-            }
-
           if ((f->sym->attr.pointer || f->sym->attr.allocatable)
               && (mpz_cmp (a->expr->ts.cl->length->value.integer,
                           f->sym->ts.cl->length->value.integer) != 0))
             {
                if (where)
-                 gfc_error ("Character length mismatch between actual argument "
-                            "and pointer or allocatable dummy argument "
-                            "'%s' at %L", f->sym->name, &a->expr->where);
+                 gfc_warning ("Character length mismatch between actual "
+                              "argument and pointer or allocatable dummy "
+                              "argument '%s' at %L",
+                              f->sym->name, &a->expr->where);
                return 0;
             }
         }
 
+      actual_size = get_expr_storage_size(a->expr);
+      formal_size = get_sym_storage_size(f->sym);
+      if (actual_size != 0 && actual_size < formal_size)
+       {
+         if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
+           gfc_warning ("Character length of actual argument shorter "
+                       "than of dummy argument '%s' (%d/%d) at %L",
+                       f->sym->name, (int) actual_size,
+                       (int) formal_size, &a->expr->where);
+          else if (where)
+           gfc_warning ("Actual argument contains too few "
+                       "elements for dummy argument '%s' (%d/%d) at %L",
+                       f->sym->name, (int) actual_size,
+                       (int) formal_size, &a->expr->where);
+         return  0;
+       }
+
       /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
         provided for a procedure formal argument.  */
       if (a->expr->ts.type != BT_PROCEDURE
index 92a17bc..934a38b 100644 (file)
@@ -1,3 +1,14 @@
+2007-07-03  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/30940
+       * gfortran.dg/argument_checking_1.f90: New.
+       * gfortran.dg/argument_checking_2.f90: New.
+       * gfortran.dg/argument_checking_3.f90: New.
+       * gfortran.dg/argument_checking_4.f90: New.
+       * gfortran.dg/argument_checking_5.f90: New.
+       * gfortran.fortran-torture/execute/st_function_1.f90: Add dg-warning.
+       * gfortran.fortran-torture/execute/st_function.f90: Add dg-warning.
+
 2007-07-03  Uros Bizjak  <ubizjak@gmail.com>
 
        * gcc.dg/pr32176.c: Add -w to default dg-options.
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_1.f90 b/gcc/testsuite/gfortran.dg/argument_checking_1.f90
new file mode 100644 (file)
index 0000000..b42047a
--- /dev/null
@@ -0,0 +1,35 @@
+! { dg-do run }
+!
+! PR fortran/30940
+program main
+  implicit none
+  character(len=10) :: digit_string = '123456789', str
+  character :: digit_arr(10)
+  call copy(digit_string, digit_arr)
+  call copy(digit_arr,str)
+  if(str /= '123456789') call abort()
+  digit_string = 'qwertasdf'
+  call copy2(digit_string, digit_arr)
+  call copy2(digit_arr,str)
+  if(str /= 'qwertasdf') call abort()
+  digit_string = '1qayxsw23e'
+  call copy3("1qayxsw23e", digit_arr)
+  call copy3(digit_arr,str)
+  if(str /= '1qayxsw23e') call abort()
+contains
+  subroutine copy(in, out)
+    character, dimension(*)  :: in
+    character, dimension(10) :: out
+    out = in(:10)
+  end subroutine copy
+  subroutine copy2(in, out)
+    character, dimension(2,*)  :: in
+    character, dimension(2,5) :: out
+    out(1:2,1:5) = in(1:2,1:5)
+  end subroutine copy2
+  subroutine copy3(in, out)
+    character(len=2), dimension(5)  :: in
+    character(len=2), dimension(5) :: out
+    out = in
+  end subroutine copy3
+end program main
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_2.f90 b/gcc/testsuite/gfortran.dg/argument_checking_2.f90
new file mode 100644 (file)
index 0000000..ba1dd63
--- /dev/null
@@ -0,0 +1,31 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+!
+! PR fortran/30940
+program main
+  implicit none
+  character(len=10) :: digit_string = '123456789', str
+  character :: digit_arr(10)
+  call copy(digit_string, digit_arr)  ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'in'" }
+  call copy(digit_arr,str)            ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'out'" }
+  if(str /= '123456789') call abort()
+  digit_string = 'qwertasdf'
+  call copy2(digit_string, digit_arr) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'in'" }
+  call copy2(digit_arr,str) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'out'" }
+  if(str /= 'qwertasdf') call abort()
+  digit_string = '1qayxsw23e'
+  call copy('1qayxsw23e', digit_arr) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'in'" }
+  call copy(digit_arr,str) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'out'" }
+  if(str /= '1qayxsw23e') call abort()
+contains
+  subroutine copy(in, out)
+    character, dimension(*)  :: in
+    character, dimension(10) :: out
+    out = in(:10)
+  end subroutine copy
+  subroutine copy2(in, out)
+    character, dimension(2,*)  :: in
+    character, dimension(2,5) :: out
+    out(1:2,1:5) = in(1:2,1:5)
+  end subroutine copy2
+end program main
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_3.f90 b/gcc/testsuite/gfortran.dg/argument_checking_3.f90
new file mode 100644 (file)
index 0000000..e59a039
--- /dev/null
@@ -0,0 +1,36 @@
+! { dg-do compile }
+!
+! PR fortran/30940
+program test
+implicit none
+interface
+  subroutine foo(a)
+     character(len=1),dimension(:) :: a
+  end subroutine foo
+  subroutine bar(a)
+     character(len=1),dimension(:,:) :: a
+  end subroutine bar
+  subroutine foobar(a)
+     character(len=1),dimension(4) :: a
+  end subroutine foobar
+  subroutine arr(a)
+     character(len=1),dimension(1,2,1,2) :: a
+  end subroutine arr
+end interface
+  character(len=2) :: len2
+  character(len=4) :: len4
+  len2 = '12'
+  len4 = '1234'
+
+  call foo(len2) ! { dg-warning "Type/rank mismatch in argument" }
+  call foo("ca") ! { dg-warning "Type/rank mismatch in argument" }
+  call bar("ca") ! { dg-warning "Type/rank mismatch in argument" }
+  call foobar(len2) ! { dg-warning "contains too few elements" }
+  call foobar(len4)
+  call foobar("bar") ! { dg-warning "contains too few elements" }
+  call foobar("bar33")
+  call arr(len2) ! { dg-warning "contains too few elements" }
+  call arr(len4)
+  call arr("bar") ! { dg-warning "contains too few elements" }
+  call arr("bar33")
+end program test
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_4.f90 b/gcc/testsuite/gfortran.dg/argument_checking_4.f90
new file mode 100644 (file)
index 0000000..a2a56e8
--- /dev/null
@@ -0,0 +1,21 @@
+! { dg-do compile }
+!
+! PR fortran/30940
+program test
+implicit none
+interface
+  subroutine foobar(a)
+     character(len=1),dimension(4) :: a
+  end subroutine foobar
+  subroutine arr(a)
+     character(len=1),dimension(1,2,1,2) :: a
+  end subroutine arr
+end interface
+
+  call foobar( [ "bar" ]) ! { dg-warning "contains too few elements" }
+  call foobar( ["ba ","r33"])
+  call arr( [ "bar" ]) ! { dg-warning "contains too few elements" }
+  call arr( reshape(["b","a","r","3"], [2,2]))
+  call arr( reshape(["b","a"], [1,2])) ! { dg-warning "contains too few elements" }
+  call arr( reshape(["b","a"], [2,1])) ! { dg-warning "contains too few elements" }
+end program test
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_5.f90 b/gcc/testsuite/gfortran.dg/argument_checking_5.f90
new file mode 100644 (file)
index 0000000..35a80a0
--- /dev/null
@@ -0,0 +1,35 @@
+! { dg-do compile }
+!
+! PR fortran/30940
+program test
+implicit none
+interface
+  subroutine foobar(x)
+     integer,dimension(4) :: x
+  end subroutine foobar
+  subroutine arr(y)
+     integer,dimension(1,2,1,2) :: y
+  end subroutine arr
+end interface
+
+integer a(3), b(5)
+call foobar(a) ! { dg-warning "contains too few elements" }
+call foobar(b)
+call foobar(b(1:3)) ! { dg-warning "contains too few elements" }
+call foobar(b(1:5))
+call foobar(b(1:5:2)) ! { dg-warning "contains too few elements" }
+call foobar(b(2))
+call foobar(b(3)) ! TODO: contains too few elements
+call foobar(reshape(a(1:3),[2,1])) ! { dg-warning "contains too few elements" }
+call foobar(reshape(b(2:5),[2,2]))
+
+call arr(a) ! { dg-warning "contains too few elements" }
+call arr(b)
+call arr(b(1:3)) ! { dg-warning "contains too few elements" }
+call arr(b(1:5))
+call arr(b(1:5:2)) ! { dg-warning "contains too few elements" }
+call arr(b(2))
+call arr(b(3)) ! TODO: contains too few elements
+call arr(reshape(a(1:3),[2,1])) ! { dg-warning "contains too few elements" }
+call arr(reshape(b(2:5),[2,2]))
+end program test
index cee55f6..97f7fb4 100644 (file)
            character(len=10), allocatable :: alloc1(:)
            character(len=20), allocatable :: alloc2(:)
            character(len=30), allocatable :: alloc3(:)
-           call foo(v) ! { dg-error "actual argument shorter than of dummy" }
-           call foo(x) ! { dg-error "actual argument shorter than of dummy" }
+           call foo(v) ! { dg-warning "actual argument shorter than of dummy" }
+           call foo(x) ! { dg-warning "actual argument shorter than of dummy" }
            call foo(y)
            call foo(z)
            ptr1 => x
-           call foo(ptr1) ! { dg-error "actual argument shorter than of dummy" }
-           call bar(ptr1) ! { dg-error "actual argument shorter than of dummy" }
+           call foo(ptr1) ! { dg-warning "actual argument shorter than of dummy" }
+           call bar(ptr1) ! { dg-warning "Character length mismatch" }
            ptr2 => y
            call foo(ptr2)
            call bar(ptr2)
            ptr3 => z
            call foo(ptr3)
-           call bar(ptr3) ! { dg-error "Character length mismatch" }
+           call bar(ptr3) ! { dg-warning "Character length mismatch" }
            allocate(alloc1(1))
            allocate(alloc2(1))
            allocate(alloc3(1))
-           call arr(alloc1) ! { dg-error "actual argument shorter than of dummy" }
+           call arr(alloc1) ! { dg-warning "Character length mismatch" }
            call arr(alloc2)
-           call arr(alloc3) ! { dg-error "Character length mismatch" }
+           call arr(alloc3) ! { dg-warning "Character length mismatch" }
         contains
         subroutine foo(y)
            character(len=20) :: y
index 8bde9b2..e878802 100644 (file)
@@ -33,7 +33,7 @@ contains
       st5 (s1, s2) = s1 // s2
 
       if (st4 (1, 4) .ne. "0123" ) call abort
-      if (st5 ("01", "02") .ne. "01  02    ") call abort
+      if (st5 ("01", "02") .ne. "01  02    ") call abort ! { dg-warning "Character length of actual argument shorter" }
    end subroutine
 
    subroutine with_derived_type_dummy
index 0387a5f..b851a94 100644 (file)
@@ -8,7 +8,7 @@ program st_function_1
   bar(p) = p // "World"
   
   ! Expression longer than function, actual arg shorter than dummy.
-  call check (foo("Hello"), "Hello Wo")
+  call check (foo("Hello"), "Hello Wo") ! { dg-warning "Character length of actual argument shorter" }
 
   ! Expression shorter than function, actual arg longer than dummy.
   ! Result shorter than type