diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 24 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 96 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 12 | ||||
| -rw-r--r-- | gcc/fortran/primary.c | 31 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 69 | ||||
| -rw-r--r-- | gcc/fortran/symbol.c | 12 | ||||
| -rw-r--r-- | gcc/fortran/trans-types.c | 17 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 8 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/external_procedures_1.f90 | 19 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 | 173 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/proc_ptr_result_2.f90 | 62 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/proc_ptr_result_3.f90 | 56 |
12 files changed, 531 insertions, 48 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c0f12e6..d24afdf 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,27 @@ +2009-04-09 Janus Weil <janus@gcc.gnu.org> + + PR fortran/36704 + * decl.c (add_hidden_procptr_result): New function for handling + procedure pointer return values by adding a hidden result variable. + (variable_decl,match_procedure_decl,gfc_match_function_decl, + gfc_match_subroutine,gfc_match_end,attr_decl1): Handle procedure pointer + return values. + * parse.c (parse_interface): Add EXTERNAL attribute only after + FUNCTION/SUBROUTINE declaration is complete. + * primary.c (replace_hidden_procptr_result): New function for replacing + function symbol by hidden result variable. + (gfc_match_rvalue,match_variable): Replace symbol by hidden result + variable. + * resolve.c (resolve_contained_fntype,resolve_function,resolve_variable, + resolve_symbol): Allow for procedure pointer function results. + (resolve_fl_procedure): Conflict detection moved here from + 'check_conflict'. + * symbol.c (gfc_check_function_type): Allow for procedure pointer + function results. + (check_conflict): Move some conflict detection to resolution stage. + * trans-types.c (gfc_sym_type,gfc_get_function_type): Handle hidden + result variables. + 2009-04-08 Jakub Jelinek <jakub@redhat.com> * trans-types.c (gfc_init_types): Ensure gfc_integer_types doesn't diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 2e54147..27fe8ff 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1667,6 +1667,17 @@ variable_decl (int elem) } } + /* Procedure pointer as function result. */ + if (gfc_current_state () == COMP_FUNCTION + && strcmp ("ppr@", gfc_current_block ()->name) == 0 + && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0) + strcpy (name, "ppr@"); + + if (gfc_current_state () == COMP_FUNCTION + && strcmp (name, gfc_current_block ()->name) == 0 + && gfc_current_block ()->result + && strcmp ("ppr@", gfc_current_block ()->result->name) == 0) + strcpy (name, "ppr@"); /* OK, we've successfully matched the declaration. Now put the symbol in the current namespace, because it might be used in the @@ -4069,6 +4080,66 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result) } +/* Procedure pointer return value without RESULT statement: + Add "hidden" result variable named "ppr@". */ + +static gfc_try +add_hidden_procptr_result (gfc_symbol *sym) +{ + bool case1,case2; + + if (gfc_notification_std (GFC_STD_F2003) == ERROR) + return FAILURE; + + /* First usage case: PROCEDURE and EXTERNAL statements. */ + case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block () + && strcmp (gfc_current_block ()->name, sym->name) == 0 + && sym->attr.external; + /* Second usage case: INTERFACE statements. */ + case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous + && gfc_state_stack->previous->state == COMP_FUNCTION + && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0; + + if (case1 || case2) + { + gfc_symtree *stree; + if (case1) + gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree); + else if (case2) + gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree); + sym->result = stree->n.sym; + + sym->result->attr.proc_pointer = sym->attr.proc_pointer; + sym->result->attr.pointer = sym->attr.pointer; + sym->result->attr.external = sym->attr.external; + sym->result->attr.referenced = sym->attr.referenced; + sym->attr.proc_pointer = 0; + sym->attr.pointer = 0; + sym->attr.external = 0; + if (sym->result->attr.external && sym->result->attr.pointer) + { + sym->result->attr.pointer = 0; + sym->result->attr.proc_pointer = 1; + } + + return gfc_add_result (&sym->result->attr, sym->result->name, NULL); + } + /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */ + else if (sym->attr.function && !sym->attr.external && sym->attr.pointer + && sym->result && sym->result != sym && sym->result->attr.external + && sym == gfc_current_ns->proc_name + && sym == sym->result->ns->proc_name + && strcmp ("ppr@", sym->result->name) == 0) + { + sym->result->attr.proc_pointer = 1; + sym->attr.pointer = 0; + return SUCCESS; + } + else + return FAILURE; +} + + /* Match a PROCEDURE declaration (R1211). */ static match @@ -4201,6 +4272,10 @@ got_ts: if (gfc_add_external (&sym->attr, NULL) == FAILURE) return MATCH_ERROR; + + if (add_hidden_procptr_result (sym) == SUCCESS) + sym = sym->result; + if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE) return MATCH_ERROR; @@ -4415,6 +4490,10 @@ gfc_match_function_decl (void) } if (get_proc_name (name, &sym, false)) return MATCH_ERROR; + + if (add_hidden_procptr_result (sym) == SUCCESS) + sym = sym->result; + gfc_new_block = sym; m = gfc_match_formal_arglist (sym, 0, 0); @@ -4812,6 +4891,10 @@ gfc_match_subroutine (void) if (get_proc_name (name, &sym, false)) return MATCH_ERROR; + + if (add_hidden_procptr_result (sym) == SUCCESS) + sym = sym->result; + gfc_new_block = sym; /* Check what next non-whitespace character is so we can tell if there @@ -5259,12 +5342,21 @@ gfc_match_end (gfc_statement *st) if (block_name == NULL) goto syntax; - if (strcmp (name, block_name) != 0) + if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0) { gfc_error ("Expected label '%s' for %s statement at %C", block_name, gfc_ascii_statement (*st)); goto cleanup; } + /* Procedure pointer as function result. */ + else if (strcmp (block_name, "ppr@") == 0 + && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0) + { + gfc_error ("Expected label '%s' for %s statement at %C", + gfc_current_block ()->ns->proc_name->name, + gfc_ascii_statement (*st)); + goto cleanup; + } if (gfc_match_eos () == MATCH_YES) return MATCH_YES; @@ -5375,6 +5467,8 @@ attr_decl1 (void) goto cleanup; } + add_hidden_procptr_result (sym); + return MATCH_YES; cleanup: diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 1925198..81e4591 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -2113,14 +2113,6 @@ loop: gfc_free_namespace (gfc_current_ns); goto loop; } - if (current_interface.type != INTERFACE_ABSTRACT && - !gfc_new_block->attr.dummy && - gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE) - { - reject_statement (); - gfc_free_namespace (gfc_current_ns); - goto loop; - } break; case ST_PROCEDURE: @@ -2213,6 +2205,10 @@ decl: goto decl; } + /* Add EXTERNAL attribute to function or subroutine. */ + if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy) + gfc_add_external (&prog_unit->attr, &gfc_current_locus); + current_interface = save; gfc_add_interface (prog_unit); pop_state (); diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index cb6f988..cab8f82 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2358,6 +2358,30 @@ check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym) } +/* Procedure pointer as function result: Replace the function symbol by the + auto-generated hidden result variable named "ppr@". */ + +static gfc_try +replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st) +{ + /* Check for procedure pointer result variable. */ + if ((*sym)->attr.function && !(*sym)->attr.external + && (*sym)->result && (*sym)->result != *sym + && (*sym)->result->attr.proc_pointer + && (*sym) == gfc_current_ns->proc_name + && (*sym) == (*sym)->result->ns->proc_name + && strcmp ("ppr@", (*sym)->result->name) == 0) + { + /* Automatic replacement with "hidden" result variable. */ + (*sym)->result->attr.referenced = (*sym)->attr.referenced; + *sym = (*sym)->result; + *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name); + return SUCCESS; + } + return FAILURE; +} + + /* Matches a variable name followed by anything that might follow it-- array reference, argument list of a function, etc. */ @@ -2394,6 +2418,8 @@ gfc_match_rvalue (gfc_expr **result) e = NULL; where = gfc_current_locus; + replace_hidden_procptr_result (&sym, &symtree); + /* If this is an implicit do loop index and implicitly typed, it should not be host associated. */ m = check_for_implicit_index (&symtree, &sym); @@ -2583,6 +2609,8 @@ gfc_match_rvalue (gfc_expr **result) gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */ sym = symtree->n.sym; + replace_hidden_procptr_result (&sym, &symtree); + e = gfc_get_expr (); e->symtree = symtree; e->expr_type = EXPR_FUNCTION; @@ -2912,7 +2940,8 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag) break; } - if (sym->attr.proc_pointer) + if (sym->attr.proc_pointer + || replace_hidden_procptr_result (&sym, &st) == SUCCESS) break; /* Fall through to error */ diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1b866d9..438b0d6 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -344,7 +344,7 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) if (sym->result == sym) gfc_error ("Contained function '%s' at %L has no IMPLICIT type", sym->name, &sym->declared_at); - else + else if (!sym->result->attr.proc_pointer) gfc_error ("Result '%s' of contained function '%s' at %L has " "no IMPLICIT type", sym->result->name, sym->name, &sym->result->declared_at); @@ -2530,7 +2530,8 @@ resolve_function (gfc_expr *expr) if (expr->ts.type == BT_UNKNOWN) { if (expr->symtree->n.sym->result - && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN) + && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN + && !expr->symtree->n.sym->result->attr.proc_pointer) expr->ts = expr->symtree->n.sym->result->ts; } @@ -4196,7 +4197,11 @@ resolve_variable (gfc_expr *e) return FAILURE; sym = e->symtree->n.sym; - if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function) + if (sym->attr.flavor == FL_PROCEDURE + && (!sym->attr.function + || (sym->attr.function && sym->result + && sym->result->attr.proc_pointer + && !sym->result->attr.function))) { e->ts.type = BT_PROCEDURE; goto resolve_procedure; @@ -8034,18 +8039,41 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) } } - if (sym->attr.save == SAVE_EXPLICIT && !sym->attr.proc_pointer) - { - gfc_error ("PROCEDURE attribute conflicts with SAVE attribute " - "in '%s' at %L", sym->name, &sym->declared_at); - return FAILURE; - } - - if (sym->attr.intent && !sym->attr.proc_pointer) + if (!sym->attr.proc_pointer) { - gfc_error ("PROCEDURE attribute conflicts with INTENT attribute " - "in '%s' at %L", sym->name, &sym->declared_at); - return FAILURE; + if (sym->attr.save == SAVE_EXPLICIT) + { + gfc_error ("PROCEDURE attribute conflicts with SAVE attribute " + "in '%s' at %L", sym->name, &sym->declared_at); + return FAILURE; + } + if (sym->attr.intent) + { + gfc_error ("PROCEDURE attribute conflicts with INTENT attribute " + "in '%s' at %L", sym->name, &sym->declared_at); + return FAILURE; + } + if (sym->attr.subroutine && sym->attr.result) + { + gfc_error ("PROCEDURE attribute conflicts with RESULT attribute " + "in '%s' at %L", sym->name, &sym->declared_at); + return FAILURE; + } + if (sym->attr.external && sym->attr.function + && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure) + || sym->attr.contained)) + { + gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute " + "in '%s' at %L", sym->name, &sym->declared_at); + return FAILURE; + } + if (strcmp ("ppr@", sym->name) == 0) + { + gfc_error ("Procedure pointer result '%s' at %L " + "is missing the pointer attribute", + sym->ns->proc_name->name, &sym->declared_at); + return FAILURE; + } } return SUCCESS; @@ -9310,11 +9338,14 @@ resolve_symbol (gfc_symbol *sym) /* Result may be in another namespace. */ resolve_symbol (sym->result); - sym->ts = sym->result->ts; - sym->as = gfc_copy_array_spec (sym->result->as); - sym->attr.dimension = sym->result->attr.dimension; - sym->attr.pointer = sym->result->attr.pointer; - sym->attr.allocatable = sym->result->attr.allocatable; + if (!sym->result->attr.proc_pointer) + { + sym->ts = sym->result->ts; + sym->as = gfc_copy_array_spec (sym->result->as); + sym->attr.dimension = sym->result->attr.dimension; + sym->attr.pointer = sym->result->attr.pointer; + sym->attr.allocatable = sym->result->attr.allocatable; + } } } } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 6ffd869..a4f43a5 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -320,7 +320,7 @@ gfc_check_function_type (gfc_namespace *ns) proc->attr.allocatable = proc->result->attr.allocatable; } } - else + else if (!proc->result->attr.proc_pointer) { gfc_error ("Function result '%s' at %L has no IMPLICIT type", proc->result->name, &proc->result->declared_at); @@ -453,10 +453,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (entry, intrinsic); if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained) - { - conf (external, subroutine); - conf (external, function); - } + conf (external, subroutine); conf (allocatable, pointer); conf_std (allocatable, dummy, GFC_STD_F2003); @@ -626,14 +623,13 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) break; case FL_PROCEDURE: - /* Conflicts with INTENT will be checked at resolution stage, - see "resolve_fl_procedure". */ + /* Conflicts with INTENT, SAVE and RESULT will be checked + at resolution stage, see "resolve_fl_procedure". */ if (attr->subroutine) { conf2 (target); conf2 (allocatable); - conf2 (result); conf2 (in_namelist); conf2 (dimension); conf2 (function); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 7cb3363..e83215c 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1616,8 +1616,8 @@ gfc_sym_type (gfc_symbol * sym) tree type; int byref; - /* Procedure Pointers inside COMMON blocks or as function result. */ - if (sym->attr.proc_pointer && (sym->attr.in_common || sym->attr.result)) + /* Procedure Pointers inside COMMON blocks. */ + if (sym->attr.proc_pointer && sym->attr.in_common) { /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */ sym->attr.proc_pointer = 0; @@ -2156,7 +2156,18 @@ gfc_get_function_type (gfc_symbol * sym) } else if (sym->result && sym->result->attr.proc_pointer) /* Procedure pointer return values. */ - type = gfc_sym_type (sym->result); + { + if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0) + { + /* Unset proc_pointer as gfc_get_function_type + is called recursively. */ + sym->result->attr.proc_pointer = 0; + type = build_pointer_type (gfc_get_function_type (sym->result)); + sym->result->attr.proc_pointer = 1; + } + else + type = gfc_sym_type (sym->result); + } else type = gfc_sym_type (sym); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0a2ff3a..de58d16 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2009-04-09 Janus Weil <janus@gcc.gnu.org> + + PR fortran/36704 + * gfortran.dg/external_procedures_1.f90: Modified. + * gfortran.dg/proc_ptr_result_1.f90: New. + * gfortran.dg/proc_ptr_result_2.f90: New. + * gfortran.dg/proc_ptr_result_3.f90: New. + 2009-04-09 Richard Guenther <rguenther@suse.de> * gcc.dg/vect/vect-54.c: Make constant input data file-scope diff --git a/gcc/testsuite/gfortran.dg/external_procedures_1.f90 b/gcc/testsuite/gfortran.dg/external_procedures_1.f90 index 6e833be..de273d5 100644 --- a/gcc/testsuite/gfortran.dg/external_procedures_1.f90 +++ b/gcc/testsuite/gfortran.dg/external_procedures_1.f90 @@ -1,14 +1,17 @@ ! { dg-do compile } +! { dg-options "-std=f95" } +! ! This tests the patch for PR25024. ! PR25024 - The external attribute for subroutine a would cause an ICE. subroutine A () EXTERNAL A ! { dg-error "EXTERNAL attribute conflicts with SUBROUTINE" } END -function ext (y) + +function ext (y) ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" } real ext, y - external ext ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" } - ext = y * y + external ext + !ext = y * y end function ext function ext1 (y) @@ -24,18 +27,18 @@ program main interface function ext1 (y) real ext1, y - external ext1 ! { dg-error "Duplicate EXTERNAL attribute" } - end function ext1 + external ext1 + end function ext1 ! { dg-error "Duplicate EXTERNAL attribute" } end interface inval = 1.0 print *, ext(inval) print *, ext1(inval) print *, inv(inval) contains - function inv (y) + function inv (y) ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" } real inv, y - external inv ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" } - inv = y * y * y + external inv + !inv = y * y * y end function inv end program main diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 new file mode 100644 index 0000000..dc09f04 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 @@ -0,0 +1,173 @@ +! { dg-do run } +! +! PR 36704: Procedure pointer as function result +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + +module mo +contains + + function j() + procedure(),pointer :: j + intrinsic iabs + j => iabs + end function + + subroutine sub(y) + integer,intent(inout) :: y + y = y**2 + end subroutine + +end module + + +program proc_ptr_14 +use mo +implicit none +intrinsic :: iabs +integer :: x +procedure(integer),pointer :: p,p2 +procedure(sub),pointer :: ps + +p => a() +if (p(-1)/=1) call abort() +p => b() +if (p(-2)/=2) call abort() +p => c() +if (p(-3)/=3) call abort() +p => d() +if (p(-4)/=4) call abort() +p => dd() +if (p(-4)/=4) call abort() +p => e(iabs) +if (p(-5)/=5) call abort() +p => ee() +if (p(-5)/=5) call abort() +p => f() +if (p(-6)/=6) call abort() +p => g() +if (p(-7)/=7) call abort() + +ps => h(sub) +x = 2 +call ps(x) +if (x/=4) call abort() + +p => i() +if (p(-8)/=8) call abort() +p => j() +if (p(-9)/=9) call abort() + +p => k(p2) +if (p(-10)/=p2(-10)) call abort() + +p => l() +if (p(-11)/=11) call abort() + +contains + + function a() + procedure(integer),pointer :: a + a => iabs + end function + + function b() + procedure(integer) :: b + pointer :: b + b => iabs + end function + + function c() + pointer :: c + procedure(integer) :: c + c => iabs + end function + + function d() + pointer :: d + external d + d => iabs + end function + + function dd() + pointer :: dd + external :: dd + integer :: dd + dd => iabs + end function + + function e(arg) + external :: e,arg + pointer :: e + e => arg + end function + + function ee() + integer :: ee + external :: ee + pointer :: ee + ee => iabs + end function + + function f() + pointer :: f + interface + integer function f(x) + integer :: x + end function + end interface + f => iabs + end function + + function g() + interface + integer function g(x) + integer :: x + end function g + end interface + pointer :: g + g => iabs + end function + + function h(arg) + interface + subroutine arg(b) + integer :: b + end subroutine arg + end interface + pointer :: h + interface + subroutine h(a) + integer :: a + end subroutine h + end interface + h => arg + end function + + function i() + pointer :: i + interface + function i(x) + integer :: i,x + end function i + end interface + i => iabs + end function + + function k(arg) + procedure(),pointer :: k,arg + k => iabs + arg => k + end function + + function l() + procedure(iabs),pointer :: l + integer :: i + l => iabs + if (l(-11)/=11) call abort() + end function + +end + +! { dg-final { cleanup-modules "mo" } } + diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_result_2.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_result_2.f90 new file mode 100644 index 0000000..362a1f7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_result_2.f90 @@ -0,0 +1,62 @@ +! { dg-do compile } +! +! PR 36704: Procedure pointer as function result +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + +module proc_ptr_15 + + interface + function e(x) + real :: x + procedure(), pointer :: e + end function e + end interface + + interface + function f(x) + real :: x + external :: f + pointer :: f + end function + end interface + + interface + function g(x) + real :: x + pointer :: g + external :: g + end function + end interface + +contains + + subroutine point_fun() + call set_fun(aux) + end subroutine + + subroutine set_fun(y) + external :: y + end subroutine + + function aux() + external aux + pointer aux + intrinsic sin + aux => sin + end function + + function foo(x) + real :: x + interface + subroutine foo(i) ! { dg-error "attribute conflicts with" } + integer :: i + end subroutine + end interface + !pointer :: foo + end function + +end + +! { dg-final { cleanup-modules "proc_ptr_15" } } + diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_result_3.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_result_3.f90 new file mode 100644 index 0000000..a84ff24 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_result_3.f90 @@ -0,0 +1,56 @@ +!{ dg-do run } +! +! PR 36704: Procedure pointer as function result +! +! Original test case from James Van Buskirk. +! +! Adapted by Janus Weil <janus@gcc.gnu.org> + +module store_subroutine + implicit none + + abstract interface + subroutine sub(i) + integer, intent(inout) :: i + end subroutine sub + end interface + + procedure(sub), pointer, private :: psub => NULL() + +contains + + subroutine set_sub(x) + procedure(sub) x + psub => x + end subroutine set_sub + + function get_sub() + procedure(sub), pointer :: get_sub + get_sub => psub + end function get_sub + +end module store_subroutine + +program test + use store_subroutine + implicit none + procedure(sub), pointer :: qsub + integer :: k = 1 + + call my_sub(k) + if (k/=3) call abort + qsub => get_sub() + call qsub(k) + if (k/=9) call abort +end program test + +recursive subroutine my_sub(j) + use store_subroutine + implicit none + integer, intent(inout) :: j + j = j*3 + call set_sub(my_sub) +end subroutine my_sub + +! { dg-final { cleanup-modules "store_subroutine" } } + |