From edc802c796309ed06d4818ad8a7c8b851a52b9ea Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Mon, 6 Aug 2012 22:36:16 +0200 Subject: [PATCH] re PR fortran/35831 ([F95] Shape mismatch check missing for dummy procedure argument) 2012-08-06 Janus Weil PR fortran/35831 * interface.c (check_result_characteristics): New function, which checks the characteristics of function results. (gfc_compare_interfaces,gfc_check_typebound_override): Call it. 2012-08-06 Janus Weil PR fortran/35831 * gfortran.dg/dummy_procedure_5.f90: Modified. * gfortran.dg/dummy_procedure_8.f90: New. * gfortran.dg/interface_26.f90: Modified. * gfortran.dg/proc_ptr_11.f90: Modified. * gfortran.dg/proc_ptr_15.f90: Modified. * gfortran.dg/proc_ptr_result_5.f90: Modified. * gfortran.dg/typebound_override_1.f90: Modified. * gfortran.dg/typebound_proc_6.f03: Modified. From-SVN: r190187 --- gcc/fortran/ChangeLog | 7 + gcc/fortran/interface.c | 211 +++++++++++++----- gcc/testsuite/ChangeLog | 12 + .../gfortran.dg/dummy_procedure_5.f90 | 2 +- .../gfortran.dg/dummy_procedure_8.f90 | 88 ++++++++ gcc/testsuite/gfortran.dg/interface_26.f90 | 2 +- gcc/testsuite/gfortran.dg/proc_ptr_11.f90 | 6 +- gcc/testsuite/gfortran.dg/proc_ptr_15.f90 | 8 +- .../gfortran.dg/proc_ptr_result_5.f90 | 3 +- .../gfortran.dg/typebound_override_1.f90 | 10 +- .../gfortran.dg/typebound_proc_6.f03 | 2 +- 11 files changed, 281 insertions(+), 70 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/dummy_procedure_8.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 211da3c6bff..278f55a337d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2012-08-06 Janus Weil + + PR fortran/35831 + * interface.c (check_result_characteristics): New function, which checks + the characteristics of function results. + (gfc_compare_interfaces,gfc_check_typebound_override): Call it. + 2012-08-02 Thomas König PR fortran/54033 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 0f8951cd7c4..473cfd17950 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1006,9 +1006,8 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, /* Check type and rank. */ if (type_must_agree && !compare_type_rank (s2, s1)) { - if (errmsg != NULL) - snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'", - s1->name); + snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'", + s1->name); return FAILURE; } @@ -1141,6 +1140,152 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, } +/* Check if the characteristics of two function results match, + cf. F08:12.3.3. */ + +static gfc_try +check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2, + char *errmsg, int err_len) +{ + gfc_symbol *r1, *r2; + + r1 = s1->result ? s1->result : s1; + r2 = s2->result ? s2->result : s2; + + if (r1->ts.type == BT_UNKNOWN) + return SUCCESS; + + /* Check type and rank. */ + if (!compare_type_rank (r1, r2)) + { + snprintf (errmsg, err_len, "Type/rank mismatch in function result"); + return FAILURE; + } + + /* Check ALLOCATABLE attribute. */ + if (r1->attr.allocatable != r2->attr.allocatable) + { + snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in " + "function result"); + return FAILURE; + } + + /* Check POINTER attribute. */ + if (r1->attr.pointer != r2->attr.pointer) + { + snprintf (errmsg, err_len, "POINTER attribute mismatch in " + "function result"); + return FAILURE; + } + + /* Check CONTIGUOUS attribute. */ + if (r1->attr.contiguous != r2->attr.contiguous) + { + snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in " + "function result"); + return FAILURE; + } + + /* Check PROCEDURE POINTER attribute. */ + if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer) + { + snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in " + "function result"); + return FAILURE; + } + + /* Check string length. */ + if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl) + { + if (r1->ts.deferred != r2->ts.deferred) + { + snprintf (errmsg, err_len, "Character length mismatch " + "in function result"); + return FAILURE; + } + + if (r1->ts.u.cl->length) + { + int compval = gfc_dep_compare_expr (r1->ts.u.cl->length, + r2->ts.u.cl->length); + switch (compval) + { + case -1: + case 1: + case -3: + snprintf (errmsg, err_len, "Character length mismatch " + "in function result"); + return FAILURE; + + case -2: + /* FIXME: Implement a warning for this case. + snprintf (errmsg, err_len, "Possible character length mismatch " + "in function result");*/ + break; + + case 0: + break; + + default: + gfc_internal_error ("check_result_characteristics (1): Unexpected " + "result %i of gfc_dep_compare_expr", compval); + break; + } + } + } + + /* Check array shape. */ + if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as) + { + int i, compval; + gfc_expr *shape1, *shape2; + + if (r1->as->type != r2->as->type) + { + snprintf (errmsg, err_len, "Shape mismatch in function result"); + return FAILURE; + } + + if (r1->as->type == AS_EXPLICIT) + for (i = 0; i < r1->as->rank + r1->as->corank; i++) + { + shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]), + gfc_copy_expr (r1->as->lower[i])); + shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]), + gfc_copy_expr (r2->as->lower[i])); + compval = gfc_dep_compare_expr (shape1, shape2); + gfc_free_expr (shape1); + gfc_free_expr (shape2); + switch (compval) + { + case -1: + case 1: + case -3: + snprintf (errmsg, err_len, "Shape mismatch in dimension %i of " + "function result", i + 1); + return FAILURE; + + case -2: + /* FIXME: Implement a warning for this case. + gfc_warning ("Possible shape mismatch in return value");*/ + break; + + case 0: + break; + + default: + gfc_internal_error ("check_result_characteristics (2): " + "Unexpected result %i of " + "gfc_dep_compare_expr", compval); + break; + } + } + } + + return SUCCESS; +} + + /* 'Compare' two formal interfaces associated with a pair of symbols. We return nonzero if there exists an actual argument list that would be ambiguous between the two interfaces, zero otherwise. @@ -1180,18 +1325,10 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, { if (s1->attr.function && s2->attr.function) { - /* If both are functions, check result type. */ - if (s1->ts.type == BT_UNKNOWN) - return 1; - if (!compare_type_rank (s1,s2)) - { - if (errmsg != NULL) - snprintf (errmsg, err_len, "Type/rank mismatch in return value " - "of '%s'", name2); - return 0; - } - - /* FIXME: Check array bounds and string length of result. */ + /* If both are functions, check result characteristics. */ + if (check_result_characteristics (s1, s2, errmsg, err_len) + == FAILURE) + return 0; } if (s1->attr.pure && !s2->attr.pure) @@ -3793,7 +3930,7 @@ gfc_try gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) { locus where; - const gfc_symbol *proc_target, *old_target; + gfc_symbol *proc_target, *old_target; unsigned proc_pass_arg, old_pass_arg, argpos; gfc_formal_arglist *proc_formal, *old_formal; bool check_type; @@ -3872,45 +4009,13 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) " FUNCTION", proc->name, &where); return FAILURE; } - - /* FIXME: Do more comprehensive checking (including, for instance, the - array-shape). */ - gcc_assert (proc_target->result && old_target->result); - if (!compare_type_rank (proc_target->result, old_target->result)) - { - gfc_error ("'%s' at %L and the overridden FUNCTION should have" - " matching result types and ranks", proc->name, &where); - return FAILURE; - } - /* Check string length. */ - if (proc_target->result->ts.type == BT_CHARACTER - && proc_target->result->ts.u.cl && old_target->result->ts.u.cl) + if (check_result_characteristics (proc_target, old_target, + err, sizeof(err)) == FAILURE) { - int compval = gfc_dep_compare_expr (proc_target->result->ts.u.cl->length, - old_target->result->ts.u.cl->length); - switch (compval) - { - case -1: - case 1: - case -3: - gfc_error ("Character length mismatch between '%s' at '%L' and " - "overridden FUNCTION", proc->name, &where); - return FAILURE; - - case -2: - gfc_warning ("Possible character length mismatch between '%s' at" - " '%L' and overridden FUNCTION", proc->name, &where); - break; - - case 0: - break; - - default: - gfc_internal_error ("gfc_check_typebound_override: Unexpected " - "result %i of gfc_dep_compare_expr", compval); - break; - } + gfc_error ("Result mismatch for the overriding procedure " + "'%s' at %L: %s", proc->name, &where, err); + return FAILURE; } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ff22fbf199c..89a6917ce47 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,15 @@ +2012-08-06 Janus Weil + + PR fortran/35831 + * gfortran.dg/dummy_procedure_5.f90: Modified. + * gfortran.dg/dummy_procedure_8.f90: New. + * gfortran.dg/interface_26.f90: Modified. + * gfortran.dg/proc_ptr_11.f90: Modified. + * gfortran.dg/proc_ptr_15.f90: Modified. + * gfortran.dg/proc_ptr_result_5.f90: Modified. + * gfortran.dg/typebound_override_1.f90: Modified. + * gfortran.dg/typebound_proc_6.f03: Modified. + 2012-08-06 Marc Glisse PR tree-optimization/51938 diff --git a/gcc/testsuite/gfortran.dg/dummy_procedure_5.f90 b/gcc/testsuite/gfortran.dg/dummy_procedure_5.f90 index 0133cbf7d1f..5ab4e7cec8e 100644 --- a/gcc/testsuite/gfortran.dg/dummy_procedure_5.f90 +++ b/gcc/testsuite/gfortran.dg/dummy_procedure_5.f90 @@ -15,7 +15,7 @@ program main end type type(u), external :: ufunc - call sub(ufunc) ! { dg-error "Type/rank mismatch in return value" } + call sub(ufunc) ! { dg-error "Type/rank mismatch in function result" } contains diff --git a/gcc/testsuite/gfortran.dg/dummy_procedure_8.f90 b/gcc/testsuite/gfortran.dg/dummy_procedure_8.f90 new file mode 100644 index 00000000000..7b8a2645f76 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dummy_procedure_8.f90 @@ -0,0 +1,88 @@ +! { dg-do compile } +! +! PR 35831: [F95] Shape mismatch check missing for dummy procedure argument +! +! Contributed by Janus Weil + +implicit none + +call call_a(a1) ! { dg-error "Character length mismatch in function result" } +call call_a(a2) ! { dg-error "Character length mismatch in function result" } +call call_b(b1) ! { dg-error "Shape mismatch" } +call call_c(c1) ! { dg-error "POINTER attribute mismatch in function result" } +call call_d(c1) ! { dg-error "ALLOCATABLE attribute mismatch in function result" } +call call_e(e1) ! { dg-error "CONTIGUOUS attribute mismatch in function result" } +call call_f(c1) ! { dg-error "PROCEDURE POINTER mismatch in function result" } + +contains + + character(1) function a1() + end function + + character(:) function a2() + end function + + subroutine call_a(a3) + interface + character(2) function a3() + end function + end interface + end subroutine + + + function b1() + integer, dimension(1:3) :: b1 + end function + + subroutine call_b(b2) + interface + function b2() + integer, dimension(0:4) :: b2 + end function + end interface + end subroutine + + + integer function c1() + end function + + subroutine call_c(c2) + interface + function c2() + integer, pointer :: c2 + end function + end interface + end subroutine + + + subroutine call_d(d2) + interface + function d2() + integer, allocatable :: d2 + end function + end interface + end subroutine + + + function e1() + integer, dimension(:), pointer :: e1 + end function + + subroutine call_e(e2) + interface + function e2() + integer, dimension(:), pointer, contiguous :: e2 + end function + end interface + end subroutine + + + subroutine call_f(f2) + interface + function f2() + procedure(integer), pointer :: f2 + end function + end interface + end subroutine + +end diff --git a/gcc/testsuite/gfortran.dg/interface_26.f90 b/gcc/testsuite/gfortran.dg/interface_26.f90 index 52e0bd138b9..330c434d2a3 100644 --- a/gcc/testsuite/gfortran.dg/interface_26.f90 +++ b/gcc/testsuite/gfortran.dg/interface_26.f90 @@ -37,7 +37,7 @@ CONTAINS END INTERFACE INTEGER, EXTERNAL :: UserOp - res = UserFunction( a,b, UserOp ) ! { dg-error "Type/rank mismatch in return value" } + res = UserFunction( a,b, UserOp ) ! { dg-error "Type/rank mismatch in function result" } if( res .lt. 10 ) then res = recSum( a, res, UserFunction, UserOp ) diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 index d1c7b4869df..e00594ab7a4 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 @@ -40,11 +40,11 @@ program bsp p2 => p1 p1 => p2 - p1 => abs ! { dg-error "Type/rank mismatch in return value" } - p2 => abs ! { dg-error "Type/rank mismatch in return value" } + p1 => abs ! { dg-error "Type/rank mismatch in function result" } + p2 => abs ! { dg-error "Type/rank mismatch in function result" } p3 => dsin - p3 => sin ! { dg-error "Type/rank mismatch in return value" } + p3 => sin ! { dg-error "Type/rank mismatch in function result" } contains diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_15.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_15.f90 index f5a748660e5..f1d3d184c96 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_15.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_15.f90 @@ -19,10 +19,10 @@ p4 => p3 p6 => p1 ! invalid -p1 => iabs ! { dg-error "Type/rank mismatch in return value" } -p1 => p2 ! { dg-error "Type/rank mismatch in return value" } -p1 => p5 ! { dg-error "Type/rank mismatch in return value" } -p6 => iabs ! { dg-error "Type/rank mismatch in return value" } +p1 => iabs ! { dg-error "Type/rank mismatch in function result" } +p1 => p2 ! { dg-error "Type/rank mismatch in function result" } +p1 => p5 ! { dg-error "Type/rank mismatch in function result" } +p6 => iabs ! { dg-error "Type/rank mismatch in function result" } p4 => p2 ! { dg-error "is not a subroutine" } contains diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 index de035233675..b021ca7c76e 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 @@ -6,7 +6,7 @@ program test procedure(real), pointer :: p - p => f() ! { dg-error "Type/rank mismatch in return value" } + p => f() ! { dg-error "Type/rank mismatch in function result" } contains function f() pointer :: f @@ -17,4 +17,3 @@ contains f = .true._1 end function f end program test - diff --git a/gcc/testsuite/gfortran.dg/typebound_override_1.f90 b/gcc/testsuite/gfortran.dg/typebound_override_1.f90 index a7e340e1b0b..96f90256342 100644 --- a/gcc/testsuite/gfortran.dg/typebound_override_1.f90 +++ b/gcc/testsuite/gfortran.dg/typebound_override_1.f90 @@ -19,11 +19,11 @@ module m type, extends(t1) :: t2 contains - procedure, nopass :: a => a2 ! { dg-error "Character length mismatch" } - procedure, nopass :: b => b2 ! { dg-error "should have matching result types and ranks" } - procedure, nopass :: c => c2 ! { dg-warning "Possible character length mismatch" } + procedure, nopass :: a => a2 ! { dg-error "Character length mismatch in function result" } + procedure, nopass :: b => b2 ! { dg-error "Type/rank mismatch in function result" } + procedure, nopass :: c => c2 ! FIXME: dg-warning "Possible character length mismatch" procedure, nopass :: d => d2 ! valid, check for commutativity (+,*) - procedure, nopass :: e => e2 ! { dg-error "Character length mismatch" } + procedure, nopass :: e => e2 ! { dg-error "Character length mismatch in function result" } end type contains @@ -110,7 +110,7 @@ module w2 type, extends(tt1) :: tt2 contains - procedure, nopass :: aa => aa2 ! { dg-warning "Possible character length mismatch" } + procedure, nopass :: aa => aa2 ! FIXME: dg-warning "Possible character length mismatch" end type contains diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 index 0f4f3118bf4..3a32cbc96a2 100644 --- a/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 @@ -72,7 +72,7 @@ MODULE testmod PROCEDURE, NOPASS :: subroutine2 => proc_intfunc ! { dg-error "must also be a SUBROUTINE" } PROCEDURE, NOPASS :: intfunction1 => proc_intfunc ! Ok, matching functions. PROCEDURE, NOPASS :: intfunction2 => proc_sub ! { dg-error "must also be a FUNCTION" } - PROCEDURE, NOPASS :: intfunction3 => proc_realfunc ! { dg-error "matching result types" } + PROCEDURE, NOPASS :: intfunction3 => proc_realfunc ! { dg-error "Type/rank mismatch in function result" } ! For access-based checks. PROCEDURE, NOPASS, PUBLIC :: priv => proc_sub ! Ok, increases visibility. -- 2.30.2