From a0324f7b5a936736a7280638998ff9d726f0349b Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Fri, 4 May 2007 09:54:06 +0200 Subject: [PATCH] re PR fortran/25071 (dummy argument larger than actual argument) 2007-05-04 Tobias Burnus PR fortran/25071 * interface.c (compare_actual_formal): Check character length. 2007-05-04 Tobias Burnus PR fortran/25071 * gfortran.dg/char_length_3.f90: New test. * gfortran.dg/char_result_2.f90: Fix test. From-SVN: r124411 --- gcc/fortran/ChangeLog | 7 ++++- gcc/fortran/interface.c | 28 +++++++++++++++++ gcc/testsuite/ChangeLog | 8 ++++- gcc/testsuite/gfortran.dg/char_length_3.f90 | 49 +++++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/char_result_2.f90 | 5 +-- 5 files changed, 93 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/char_length_3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 66e6158..aa9fb99 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,6 +1,11 @@ +2007-05-04 Tobias Burnus + + PR fortran/25071 + * interface.c (compare_actual_formal): Check character length. + 2007-05-01 Thomas Koenig - PR fortran/31732 + PR fortran/31732 * dependency.c (gfc_full_array_ref_p): If the reference is to a single element, check that the array has a single element and that the correct element is referenced. diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 1672b1c..22a39b5 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1369,6 +1369,34 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, return 0; } + 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); + 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 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1f0e637..c55266a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2007-05-04 Tobias Burnus + + PR fortran/25071 + * gfortran.dg/char_length_3.f90: New test. + * gfortran.dg/char_result_2.f90: Fix test. + 2007-05-03 Zdenek Dvorak PR tree-optimization/30565 @@ -81,7 +87,7 @@ 2007-05-01 Thomas Koenig - PR fortran/31732 + PR fortran/31732 * gfortran.dg/array_memset_2: New test case. 2007-05-01 Dorit Nuzman diff --git a/gcc/testsuite/gfortran.dg/char_length_3.f90 b/gcc/testsuite/gfortran.dg/char_length_3.f90 new file mode 100644 index 0000000..cee55f6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/char_length_3.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! PR fortran/25071 +! Check if actual argument is too short +! + program test + implicit none + character(len=10) :: v + character(len=10), target :: x + character(len=20), target :: y + character(len=30), target :: z + character(len=10), pointer :: ptr1 + character(len=20), pointer :: ptr2 + character(len=30), pointer :: ptr3 + 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(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" } + ptr2 => y + call foo(ptr2) + call bar(ptr2) + ptr3 => z + call foo(ptr3) + call bar(ptr3) ! { dg-error "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(alloc2) + call arr(alloc3) ! { dg-error "Character length mismatch" } + contains + subroutine foo(y) + character(len=20) :: y + y = 'hello world' + end subroutine + subroutine bar(y) + character(len=20),pointer :: y + y = 'hello world' + end subroutine + subroutine arr(y) + character(len=20),allocatable :: y(:) + y(1) = 'hello world' + end subroutine + end diff --git a/gcc/testsuite/gfortran.dg/char_result_2.f90 b/gcc/testsuite/gfortran.dg/char_result_2.f90 index b7ecb66..0df43aa 100644 --- a/gcc/testsuite/gfortran.dg/char_result_2.f90 +++ b/gcc/testsuite/gfortran.dg/char_result_2.f90 @@ -42,9 +42,11 @@ program main character (len = 80) :: text character (len = 70), target :: textt character (len = 70), pointer :: textp + character (len = 50), pointer :: textp2 a = 42 textp => textt + ! textp2 => textt(1:50) ! needs fixed PR31803 call test (f1 (textp), 70) call test (f2 (textp, textp), 95) @@ -53,7 +55,7 @@ program main call test (f5 (textp), 140) call test (f6 (textp), 29) - call indirect (textp) + ! call indirect (textp2) ! needs fixed PR31803 contains function f3 (string) integer, parameter :: l1 = 30 @@ -93,7 +95,6 @@ contains call test (f1 (textp2), 50) call test (f2 (textp2, textp), 65) call test (f3 (textp2), 85) - call test (f4 (textp2), 192) call test (f5 (textp2), 100) call test (f6 (textp2), 9) end subroutine indirect -- 2.7.4