Index: gcc/testsuite/gfortran.dg/proc_ptr_11.f90 =================================================================== --- gcc/testsuite/gfortran.dg/proc_ptr_11.f90 (revision 190067) +++ gcc/testsuite/gfortran.dg/proc_ptr_11.f90 (working copy) @@ -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 Index: gcc/testsuite/gfortran.dg/interface_26.f90 =================================================================== --- gcc/testsuite/gfortran.dg/interface_26.f90 (revision 190067) +++ gcc/testsuite/gfortran.dg/interface_26.f90 (working copy) @@ -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 ) Index: gcc/testsuite/gfortran.dg/typebound_override_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/typebound_override_1.f90 (revision 190067) +++ gcc/testsuite/gfortran.dg/typebound_override_1.f90 (working copy) @@ -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 Index: gcc/testsuite/gfortran.dg/proc_ptr_15.f90 =================================================================== --- gcc/testsuite/gfortran.dg/proc_ptr_15.f90 (revision 190067) +++ gcc/testsuite/gfortran.dg/proc_ptr_15.f90 (working copy) @@ -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 Index: gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 =================================================================== --- gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 (revision 190067) +++ gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 (working copy) @@ -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 - Index: gcc/testsuite/gfortran.dg/typebound_proc_6.f03 =================================================================== --- gcc/testsuite/gfortran.dg/typebound_proc_6.f03 (revision 190067) +++ gcc/testsuite/gfortran.dg/typebound_proc_6.f03 (working copy) @@ -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. Index: gcc/testsuite/gfortran.dg/dummy_procedure_5.f90 =================================================================== --- gcc/testsuite/gfortran.dg/dummy_procedure_5.f90 (revision 190067) +++ gcc/testsuite/gfortran.dg/dummy_procedure_5.f90 (working copy) @@ -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 Index: gcc/fortran/interface.c =================================================================== --- gcc/fortran/interface.c (revision 190067) +++ gcc/fortran/interface.c (working copy) @@ -1141,6 +1141,129 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_s } +/* 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)) + { + if (errmsg != NULL) + 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 mismatch in function result"); + return FAILURE; + } + + /* Check POINTER attribute. */ + if (r1->attr.pointer != r2->attr.pointer) + { + snprintf (errmsg, err_len, "POINTER mismatch in function result"); + return FAILURE; + } + + /* FIXME: Do more comprehensive checking of attributes, like e.g. + 'contiguous' and 'proc_pointer'. */ + + /* Check string length. */ + if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl + && 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 +1303,10 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol { 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 +3908,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,46 +3987,14 @@ gfc_check_typebound_override (gfc_symtree* proc, g " 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)) + + if (check_result_characteristics (proc_target, old_target, + err, sizeof(err)) == FAILURE) { - gfc_error ("'%s' at %L and the overridden FUNCTION should have" - " matching result types and ranks", proc->name, &where); + gfc_error ("Result mismatch for the overriding procedure " + "'%s' at %L: %s", proc->name, &where, err); 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) - { - 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; - } - } } /* If the overridden binding is PUBLIC, the overriding one must not be