From 726d8566c19edbbf347cac9dd93fd263a7fd8ce4 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Tue, 2 Dec 2008 12:58:16 +0100 Subject: [PATCH] re PR fortran/36704 (Procedure pointer as function result) 2008-12-02 Janus Weil PR fortran/36704 PR fortran/38290 * decl.c (match_result): Result may be a standard variable or a procedure pointer. * expr.c (gfc_check_pointer_assign): Additional checks for procedure pointer assignments. * primary.c (gfc_match_rvalue): Bugfix for procedure pointer assignments. * resolve.c (resolve_function): Check for attr.subroutine. * symbol.c (check_conflict): Addtional checks for RESULT statements. * trans-types.c (gfc_sym_type,gfc_get_function_type): Support procedure pointers as function result. 2008-12-02 Janus Weil PR fortran/36704 PR fortran/38290 * gfortran.dg/entry_7.f90: Modified. * gfortran.dg/proc_ptr_2.f90: Extended. * gfortran.dg/proc_ptr_3.f90: Modified. * gfortran.dg/proc_ptr_11.f90: New. * gfortran.dg/proc_ptr_12.f90: New. * gfortran.dg/result_1.f90: New. From-SVN: r142351 --- gcc/fortran/ChangeLog | 15 ++++++++++++ gcc/fortran/decl.c | 3 +-- gcc/fortran/expr.c | 25 +++++++++++++++++-- gcc/fortran/primary.c | 3 +-- gcc/fortran/resolve.c | 2 +- gcc/fortran/symbol.c | 5 ++++ gcc/fortran/trans-types.c | 7 ++++-- gcc/testsuite/ChangeLog | 11 +++++++++ gcc/testsuite/gfortran.dg/entry_7.f90 | 2 +- gcc/testsuite/gfortran.dg/proc_ptr_11.f90 | 30 +++++++++++++++++++++++ gcc/testsuite/gfortran.dg/proc_ptr_12.f90 | 15 ++++++++++++ gcc/testsuite/gfortran.dg/proc_ptr_2.f90 | 5 +++- gcc/testsuite/gfortran.dg/proc_ptr_3.f90 | 12 ++++++--- gcc/testsuite/gfortran.dg/result_1.f90 | 18 ++++++++++++++ 14 files changed, 139 insertions(+), 14 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_11.f90 create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_12.f90 create mode 100644 gcc/testsuite/gfortran.dg/result_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 732b0f7a497..d3ae07fe273 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2008-12-02 Janus Weil + + PR fortran/36704 + PR fortran/38290 + * decl.c (match_result): Result may be a standard variable or a + procedure pointer. + * expr.c (gfc_check_pointer_assign): Additional checks for procedure + pointer assignments. + * primary.c (gfc_match_rvalue): Bugfix for procedure pointer + assignments. + * resolve.c (resolve_function): Check for attr.subroutine. + * symbol.c (check_conflict): Addtional checks for RESULT statements. + * trans-types.c (gfc_sym_type,gfc_get_function_type): Support procedure + pointers as function result. + 2008-12-01 Mikael Morin PR fortran/38252 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 14ccb6081a8..f6677fe42e0 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -3974,8 +3974,7 @@ match_result (gfc_symbol *function, gfc_symbol **result) if (gfc_get_symbol (name, NULL, &r)) return MATCH_ERROR; - if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE - || gfc_add_result (&r->attr, r->name, NULL) == FAILURE) + if (gfc_add_result (&r->attr, r->name, NULL) == FAILURE) return MATCH_ERROR; *result = r; diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 4017cf91f33..b94e5ac0b87 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3112,9 +3112,30 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) return SUCCESS; - /* TODO checks on rvalue for a procedure pointer assignment. */ + /* Checks on rvalue for procedure pointer assignments. */ if (lvalue->symtree->n.sym->attr.proc_pointer) - return SUCCESS; + { + attr = gfc_expr_attr (rvalue); + if (!((rvalue->expr_type == EXPR_NULL) + || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer) + || (rvalue->expr_type == EXPR_VARIABLE + && attr.flavor == FL_PROCEDURE))) + { + gfc_error ("Invalid procedure pointer assignment at %L", + &rvalue->where); + return FAILURE; + } + if (rvalue->expr_type == EXPR_VARIABLE + && lvalue->symtree->n.sym->attr.if_source != IFSRC_UNKNOWN + && !gfc_compare_interfaces (lvalue->symtree->n.sym, + rvalue->symtree->n.sym, 0)) + { + gfc_error ("Interfaces don't match " + "in procedure pointer assignment at %L", &rvalue->where); + return FAILURE; + } + return SUCCESS; + } if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) { diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index f3e1b038918..032fa9024b4 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2509,11 +2509,10 @@ gfc_match_rvalue (gfc_expr **result) if (gfc_matching_procptr_assignment) { gfc_gobble_whitespace (); - if (sym->attr.function && gfc_peek_ascii_char () == '(') + if (gfc_peek_ascii_char () == '(') /* Parse functions returning a procptr. */ goto function0; - if (sym->attr.flavor == FL_UNKNOWN) sym->attr.flavor = FL_PROCEDURE; if (gfc_is_intrinsic (sym, 0, gfc_current_locus) || gfc_is_intrinsic (sym, 1, gfc_current_locus)) sym->attr.intrinsic = 1; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 6ccbe12859a..0b6fe4c13a9 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2327,7 +2327,7 @@ resolve_function (gfc_expr *expr) return FAILURE; } - if (sym && sym->attr.flavor == FL_VARIABLE) + if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine)) { gfc_error ("'%s' at %L is not a function", sym->name, &expr->where); return FAILURE; diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 4e81b89e2b0..7c79ef80afa 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -618,7 +618,10 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) break; case FL_VARIABLE: + break; + case FL_NAMELIST: + conf2 (result); break; case FL_PROCEDURE: @@ -672,6 +675,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (function); conf2 (subroutine); conf2 (threadprivate); + conf2 (result); if (attr->intent != INTENT_UNKNOWN) { @@ -698,6 +702,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (threadprivate); conf2 (value); conf2 (is_bind_c); + conf2 (result); break; default: diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index de629646ec8..e1ff5aadde5 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1613,8 +1613,8 @@ gfc_sym_type (gfc_symbol * sym) tree type; int byref; - /* Procedure Pointers inside COMMON blocks. */ - if (sym->attr.proc_pointer && sym->attr.in_common) + /* Procedure Pointers inside COMMON blocks or as function result. */ + if (sym->attr.proc_pointer && (sym->attr.in_common || sym->attr.result)) { /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */ sym->attr.proc_pointer = 0; @@ -2143,6 +2143,9 @@ gfc_get_function_type (gfc_symbol * sym) type = gfc_typenode_for_spec (&sym->ts); sym->ts.kind = gfc_default_real_kind; } + else if (sym->result && sym->result->attr.proc_pointer) + /* Procedure pointer return values. */ + type = gfc_sym_type (sym->result); else type = gfc_sym_type (sym); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ad317b7820a..f64db4d4cf7 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,14 @@ +2008-12-02 Janus Weil + + PR fortran/36704 + PR fortran/38290 + * gfortran.dg/entry_7.f90: Modified. + * gfortran.dg/proc_ptr_2.f90: Extended. + * gfortran.dg/proc_ptr_3.f90: Modified. + * gfortran.dg/proc_ptr_11.f90: New. + * gfortran.dg/proc_ptr_12.f90: New. + * gfortran.dg/result_1.f90: New. + 2008-12-02 Jakub Jelinek PR middle-end/38343 diff --git a/gcc/testsuite/gfortran.dg/entry_7.f90 b/gcc/testsuite/gfortran.dg/entry_7.f90 index fbe4b8e2af1..52940984551 100644 --- a/gcc/testsuite/gfortran.dg/entry_7.f90 +++ b/gcc/testsuite/gfortran.dg/entry_7.f90 @@ -9,7 +9,7 @@ MODULE TT CONTAINS FUNCTION K(I) RESULT(J) - ENTRY J() ! { dg-error "conflicts with PROCEDURE attribute" } + ENTRY J() ! { dg-error "conflicts with RESULT attribute" } END FUNCTION K integer function foo () diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 new file mode 100644 index 00000000000..a5cdbb54890 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR 38290: Procedure pointer assignment checking. +! +! Test case found at http://de.wikibooks.org/wiki/Fortran:_Fortran_2003:_Zeiger +! Adapted by Janus Weil + +program bsp + implicit none + + abstract interface + subroutine up() + end subroutine up + end interface + + procedure( up ) , pointer :: pptr + + pptr => add ! { dg-error "Interfaces don't match" } + + print *, pptr() ! { dg-error "is not a function" } + + contains + + function add( a, b ) + integer :: add + integer, intent( in ) :: a, b + add = a + b + end function add + +end program bsp diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_12.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_12.f90 new file mode 100644 index 00000000000..325703f499d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_12.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! +! PR 36704: Procedure pointer as function result +! +! Contributed by Janus Weil + +procedure(integer),pointer :: p +p => foo() +if (p(-1)/=1) call abort +contains + function foo() result(bar) + procedure(integer),pointer :: bar + bar => iabs + end function +end diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_2.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_2.f90 index d19b81d6e47..6224dc5980b 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_2.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_2.f90 @@ -6,8 +6,11 @@ PROCEDURE(REAL), POINTER :: ptr PROCEDURE(REAL), SAVE :: noptr ! { dg-error "attribute conflicts with" } +REAL :: x -ptr => cos(4.0) ! { dg-error "Invalid character" } +ptr => cos(4.0) ! { dg-error "Invalid procedure pointer assignment" } +ptr => x ! { dg-error "Invalid procedure pointer assignment" } +ptr => sin(x) ! { dg-error "Invalid procedure pointer assignment" } ALLOCATE(ptr) ! { dg-error "must be ALLOCATABLE" } diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_3.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_3.f90 index 34d4f1625fb..5c4233d60e4 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_3.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_3.f90 @@ -6,14 +6,12 @@ real function e1(x) real :: x - print *,'e1!',x e1 = x * 3.0 end function subroutine e2(a,b) real, intent(inout) :: a real, intent(in) :: b - print *,'e2!',a,b a = a + b end subroutine @@ -29,7 +27,15 @@ interface end subroutine sp end interface -external :: e1,e2 +external :: e1 + +interface + subroutine e2(a,b) + real, intent(inout) :: a + real, intent(in) :: b + end subroutine e2 +end interface + real :: c = 1.2 fp => e1 diff --git a/gcc/testsuite/gfortran.dg/result_1.f90 b/gcc/testsuite/gfortran.dg/result_1.f90 new file mode 100644 index 00000000000..162ffaf5857 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/result_1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR 36704: Procedure pointer as function result +! +! Contributed by Janus Weil + +function f() result(r) +real, parameter :: r = 5.0 ! { dg-error "attribute conflicts" } +end function + +function g() result(s) +real :: a,b,c +namelist /s/ a,b,c ! { dg-error "attribute conflicts" } +end function + +function h() result(t) +type t ! { dg-error "attribute conflicts" } +end function