From: janus Date: Sat, 25 Jul 2009 11:56:35 +0000 (+0000) Subject: 2009-07-25 Janus Weil X-Git-Tag: upstream/4.9.2~34626 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=fe9b08a2c2202c07f1f02f83e8dfac36923b6662;p=platform%2Fupstream%2Flinaro-gcc.git 2009-07-25 Janus Weil PR fortran/39630 * decl.c (match_ppc_decl): Implement the PASS attribute for procedure pointer components. (match_binding_attributes): Ditto. * gfortran.h (gfc_component): Add member 'tb'. (gfc_typebound_proc): Add member 'ppc' and make 'pass_arg' const. * module.c (MOD_VERSION): Bump module version. (binding_ppc): New string constants. (mio_component): Only use formal args if component is a procedure pointer and add 'tb' member. (mio_typebound_proc): Include pass_arg and take care of procedure pointer components. * resolve.c (update_arglist_pass): Add argument 'name' and take care of optional arguments. (extract_ppc_passed_object): New function, analogous to extract_compcall_passed_object, but for procedure pointer components. (update_ppc_arglist): New function, analogous to update_compcall_arglist, but for procedure pointer components. (resolve_typebound_generic_call): Added argument to update_arglist_pass. (resolve_ppc_call, resolve_expr_ppc): Take care of PASS attribute. (resolve_fl_derived): Check the PASS argument for procedure pointer components. * symbol.c (verify_bind_c_derived_type): Reject procedure pointer components in BIND(C) types. 2009-07-25 Janus Weil PR fortran/39630 * gfortran.dg/proc_ptr_comp_3.f90: Modified. * gfortran.dg/proc_ptr_comp_pass_1.f90: New. * gfortran.dg/proc_ptr_comp_pass_2.f90: New. * gfortran.dg/proc_ptr_comp_pass_3.f90: New. * gfortran.dg/proc_ptr_comp_pass_4.f90: New. * gfortran.dg/proc_ptr_comp_pass_5.f90: New. * gfortran.dg/typebound_call_10.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150078 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5f6cf27..86f0662 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,30 @@ +2009-07-25 Janus Weil + + PR fortran/39630 + * decl.c (match_ppc_decl): Implement the PASS attribute for procedure + pointer components. + (match_binding_attributes): Ditto. + * gfortran.h (gfc_component): Add member 'tb'. + (gfc_typebound_proc): Add member 'ppc' and make 'pass_arg' const. + * module.c (MOD_VERSION): Bump module version. + (binding_ppc): New string constants. + (mio_component): Only use formal args if component is a procedure + pointer and add 'tb' member. + (mio_typebound_proc): Include pass_arg and take care of procedure + pointer components. + * resolve.c (update_arglist_pass): Add argument 'name' and take care of + optional arguments. + (extract_ppc_passed_object): New function, analogous to + extract_compcall_passed_object, but for procedure pointer components. + (update_ppc_arglist): New function, analogous to + update_compcall_arglist, but for procedure pointer components. + (resolve_typebound_generic_call): Added argument to update_arglist_pass. + (resolve_ppc_call, resolve_expr_ppc): Take care of PASS attribute. + (resolve_fl_derived): Check the PASS argument for procedure pointer + components. + * symbol.c (verify_bind_c_derived_type): Reject procedure pointer + components in BIND(C) types. + 2009-07-24 Janus Weil PR fortran/40822 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 0207683..392f2a5 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -4411,14 +4411,6 @@ match_ppc_decl (void) if (m == MATCH_ERROR) return m; - /* TODO: Implement PASS. */ - if (!tb->nopass) - { - gfc_error ("Procedure Pointer Component with PASS at %C " - "not yet implemented"); - return MATCH_ERROR; - } - gfc_clear_attr (¤t_attr); current_attr.procedure = 1; current_attr.proc_pointer = 1; @@ -4462,6 +4454,8 @@ match_ppc_decl (void) if (gfc_add_proc (&c->attr, name, NULL) == FAILURE) return MATCH_ERROR; + c->tb = tb; + /* Set interface. */ if (proc_if != NULL) { @@ -7028,7 +7022,7 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc) { bool found_passing = false; bool seen_ptr = false; - match m; + match m = MATCH_YES; /* Intialize to defaults. Do so even before the MATCH_NO check so that in this case the defaults are in there. */ @@ -7038,13 +7032,12 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc) ba->nopass = 0; ba->non_overridable = 0; ba->deferred = 0; + ba->ppc = ppc; /* If we find a comma, we believe there are binding attributes. */ - if (gfc_match_char (',') == MATCH_NO) - { - ba->access = gfc_typebound_default_access; - return MATCH_NO; - } + m = gfc_match_char (','); + if (m == MATCH_NO) + goto done; do { @@ -7121,7 +7114,7 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc) if (m == MATCH_ERROR) goto error; if (m == MATCH_YES) - ba->pass_arg = xstrdup (arg); + ba->pass_arg = gfc_get_string (arg); gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL)); found_passing = true; @@ -7144,7 +7137,6 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc) } seen_ptr = true; - /*ba->ppc = 1;*/ continue; } } @@ -7201,6 +7193,9 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc) goto error; } + m = MATCH_YES; + +done: if (ba->access == ACCESS_UNKNOWN) ba->access = gfc_typebound_default_access; @@ -7211,10 +7206,9 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc) goto error; } - return MATCH_YES; + return m; error: - gfc_free (ba->pass_arg); return MATCH_ERROR; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index ce8e6fc..7792cfa 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -879,8 +879,10 @@ typedef struct gfc_component struct gfc_expr *initializer; struct gfc_component *next; + /* Needed for procedure pointer components. */ struct gfc_formal_arglist *formal; struct gfc_namespace *formal_ns; + struct gfc_typebound_proc *tb; } gfc_component; @@ -1064,7 +1066,7 @@ typedef struct gfc_typebound_proc u; gfc_access access; - char* pass_arg; /* Argument-name for PASS. NULL if not specified. */ + const char* pass_arg; /* Argument-name for PASS. NULL if not specified. */ /* The overridden type-bound proc (or GENERIC with this name in the parent-type) or NULL if non. */ @@ -1081,6 +1083,7 @@ typedef struct gfc_typebound_proc unsigned is_generic:1; unsigned function:1, subroutine:1; unsigned error:1; /* Ignore it, when an error occurred during resolution. */ + unsigned ppc:1; } gfc_typebound_proc; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 425bd36..eff482c 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -77,7 +77,7 @@ along with GCC; see the file COPYING3. If not see /* Don't put any single quote (') in MOD_VERSION, if yout want it to be recognized. */ -#define MOD_VERSION "1" +#define MOD_VERSION "2" /* Structure that describes a position within a module file. */ @@ -1719,7 +1719,12 @@ static const mstring binding_generic[] = minit ("GENERIC", 1), minit (NULL, -1) }; - +static const mstring binding_ppc[] = +{ + minit ("NO_PPC", 0), + minit ("PPC", 1), + minit (NULL, -1) +}; /* Specialization of mio_name. */ DECL_MIO_NAME (ab_attribute) @@ -2260,7 +2265,7 @@ mio_component_ref (gfc_component **cp, gfc_symbol *sym) static void mio_namespace_ref (gfc_namespace **nsp); static void mio_formal_arglist (gfc_formal_arglist **formal); - +static void mio_typebound_proc (gfc_typebound_proc** proc); static void mio_component (gfc_component *c) @@ -2295,28 +2300,33 @@ mio_component (gfc_component *c) mio_expr (&c->initializer); - if (iomode == IO_OUTPUT) + if (c->attr.proc_pointer) { - formal = c->formal; - while (formal && !formal->sym) - formal = formal->next; + if (iomode == IO_OUTPUT) + { + formal = c->formal; + while (formal && !formal->sym) + formal = formal->next; - if (formal) - mio_namespace_ref (&formal->sym->ns); + if (formal) + mio_namespace_ref (&formal->sym->ns); + else + mio_namespace_ref (&c->formal_ns); + } else - mio_namespace_ref (&c->formal_ns); - } - else - { - mio_namespace_ref (&c->formal_ns); - /* TODO: if (c->formal_ns) { - c->formal_ns->proc_name = c; - c->refs++; - }*/ - } + mio_namespace_ref (&c->formal_ns); + /* TODO: if (c->formal_ns) + { + c->formal_ns->proc_name = c; + c->refs++; + }*/ + } + + mio_formal_arglist (&c->formal); - mio_formal_arglist (&c->formal); + mio_typebound_proc (&c->tb); + } mio_rparen (); } @@ -3265,9 +3275,9 @@ mio_typebound_proc (gfc_typebound_proc** proc) (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing); (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic); + (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc); - if (iomode == IO_INPUT) - (*proc)->pass_arg = NULL; + mio_pool_string (&((*proc)->pass_arg)); flag = (int) (*proc)->pass_arg_num; mio_integer (&flag); @@ -3304,7 +3314,7 @@ mio_typebound_proc (gfc_typebound_proc** proc) mio_rparen (); } - else + else if (!(*proc)->ppc) mio_symtree_ref (&(*proc)->u.specific); mio_rparen (); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e09167b..aaab554 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4535,7 +4535,8 @@ fixup_charlen (gfc_expr *e) procedures at the right position. */ static gfc_actual_arglist* -update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos) +update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos, + const char *name) { gcc_assert (argpos > 0); @@ -4546,14 +4547,16 @@ update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos) result = gfc_get_actual_arglist (); result->expr = po; result->next = lst; + if (name) + result->name = name; return result; } - gcc_assert (lst); - gcc_assert (argpos > 1); - - lst->next = update_arglist_pass (lst->next, po, argpos - 1); + if (lst) + lst->next = update_arglist_pass (lst->next, po, argpos - 1, name); + else + lst = update_arglist_pass (NULL, po, argpos - 1, name); return lst; } @@ -4611,7 +4614,74 @@ update_compcall_arglist (gfc_expr* e) gcc_assert (tbp->pass_arg_num > 0); e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po, - tbp->pass_arg_num); + tbp->pass_arg_num, + tbp->pass_arg); + + return SUCCESS; +} + + +/* Extract the passed object from a PPC call (a copy of it). */ + +static gfc_expr* +extract_ppc_passed_object (gfc_expr *e) +{ + gfc_expr *po; + gfc_ref **ref; + + po = gfc_get_expr (); + po->expr_type = EXPR_VARIABLE; + po->symtree = e->symtree; + po->ref = gfc_copy_ref (e->ref); + + /* Remove PPC reference. */ + ref = &po->ref; + while ((*ref)->next) + (*ref) = (*ref)->next; + gfc_free_ref_list (*ref); + *ref = NULL; + + if (gfc_resolve_expr (po) == FAILURE) + return NULL; + + return po; +} + + +/* Update the actual arglist of a procedure pointer component to include the + passed-object. */ + +static gfc_try +update_ppc_arglist (gfc_expr* e) +{ + gfc_expr* po; + gfc_component *ppc; + gfc_typebound_proc* tb; + + if (!gfc_is_proc_ptr_comp (e, &ppc)) + return FAILURE; + + tb = ppc->tb; + + if (tb->error) + return FAILURE; + else if (tb->nopass) + return SUCCESS; + + po = extract_ppc_passed_object (e); + if (!po) + return FAILURE; + + if (po->rank > 0) + { + gfc_error ("Passed-object at %L must be scalar", &e->where); + return FAILURE; + } + + gcc_assert (tb->pass_arg_num > 0); + e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po, + tb->pass_arg_num, + tb->pass_arg); return SUCCESS; } @@ -4714,7 +4784,8 @@ resolve_typebound_generic_call (gfc_expr* e) gcc_assert (g->specific->pass_arg_num > 0); gcc_assert (!g->specific->error); - args = update_arglist_pass (args, po, g->specific->pass_arg_num); + args = update_arglist_pass (args, po, g->specific->pass_arg_num, + g->specific->pass_arg); } resolve_actual_arglist (args, target->attr.proc, is_external_proc (target) && !target->formal); @@ -4836,7 +4907,6 @@ resolve_ppc_call (gfc_code* c) c->resolved_sym = c->expr1->symtree->n.sym; c->expr1->expr_type = EXPR_VARIABLE; - c->ext.actual = c->expr1->value.compcall.actual; if (!comp->attr.subroutine) gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where); @@ -4844,6 +4914,11 @@ resolve_ppc_call (gfc_code* c) if (resolve_ref (c->expr1) == FAILURE) return FAILURE; + if (update_ppc_arglist (c->expr1) == FAILURE) + return FAILURE; + + c->ext.actual = c->expr1->value.compcall.actual; + if (resolve_actual_arglist (c->ext.actual, comp->attr.proc, comp->formal == NULL) == FAILURE) return FAILURE; @@ -4880,6 +4955,9 @@ resolve_expr_ppc (gfc_expr* e) comp->formal == NULL) == FAILURE) return FAILURE; + if (update_ppc_arglist (e) == FAILURE) + return FAILURE; + gfc_ppc_use (comp, &e->value.compcall.actual, &e->where); return SUCCESS; @@ -9095,6 +9173,103 @@ resolve_fl_derived (gfc_symbol *sym) c->attr.implicit_type = 1; } + /* Procedure pointer components: Check PASS arg. */ + if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0) + { + gfc_symbol* me_arg; + + if (c->tb->pass_arg) + { + gfc_formal_arglist* i; + + /* If an explicit passing argument name is given, walk the arg-list + and look for it. */ + + me_arg = NULL; + c->tb->pass_arg_num = 1; + for (i = c->formal; i; i = i->next) + { + if (!strcmp (i->sym->name, c->tb->pass_arg)) + { + me_arg = i->sym; + break; + } + c->tb->pass_arg_num++; + } + + if (!me_arg) + { + gfc_error ("Procedure pointer component '%s' with PASS(%s) " + "at %L has no argument '%s'", c->name, + c->tb->pass_arg, &c->loc, c->tb->pass_arg); + c->tb->error = 1; + return FAILURE; + } + } + else + { + /* Otherwise, take the first one; there should in fact be at least + one. */ + c->tb->pass_arg_num = 1; + if (!c->formal) + { + gfc_error ("Procedure pointer component '%s' with PASS at %L " + "must have at least one argument", + c->name, &c->loc); + c->tb->error = 1; + return FAILURE; + } + me_arg = c->formal->sym; + } + + /* Now check that the argument-type matches. */ + gcc_assert (me_arg); + if (me_arg->ts.type != BT_DERIVED + || me_arg->ts.derived != sym) + { + gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" + " the derived type '%s'", me_arg->name, c->name, + me_arg->name, &c->loc, sym->name); + c->tb->error = 1; + return FAILURE; + } + + /* Check for C453. */ + if (me_arg->attr.dimension) + { + gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L " + "must be scalar", me_arg->name, c->name, me_arg->name, + &c->loc); + c->tb->error = 1; + return FAILURE; + } + + if (me_arg->attr.pointer) + { + gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L " + "may not have the POINTER attribute", me_arg->name, + c->name, me_arg->name, &c->loc); + c->tb->error = 1; + return FAILURE; + } + + if (me_arg->attr.allocatable) + { + gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L " + "may not be ALLOCATABLE", me_arg->name, c->name, + me_arg->name, &c->loc); + c->tb->error = 1; + return FAILURE; + } + + /* TODO: Make this an error once CLASS is implemented. */ + if (!sym->attr.sequence) + gfc_warning ("Polymorphic entities are not yet implemented," + " non-polymorphic passed-object dummy argument of '%s'" + " at %L accepted", c->name, &c->loc); + + } + /* Check type-spec if this is not the parent-type component. */ if ((!sym->attr.extension || c != sym->components) && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE) diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index dd06e48..ec4afbe 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -3452,6 +3452,15 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) retval = FAILURE; } + if (curr_comp->attr.proc_pointer != 0) + { + gfc_error ("Procedure pointer component '%s' at %L cannot be a member" + " of the BIND(C) derived type '%s' at %L", curr_comp->name, + &curr_comp->loc, derived_sym->name, + &derived_sym->declared_at); + retval = FAILURE; + } + /* The components cannot be allocatable. J3/04-007, Section 15.2.3, C1505. */ if (curr_comp->attr.allocatable != 0) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 00dbba7..71f3ad9 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,14 @@ +2009-07-25 Janus Weil + + PR fortran/39630 + * gfortran.dg/proc_ptr_comp_3.f90: Modified. + * gfortran.dg/proc_ptr_comp_pass_1.f90: New. + * gfortran.dg/proc_ptr_comp_pass_2.f90: New. + * gfortran.dg/proc_ptr_comp_pass_3.f90: New. + * gfortran.dg/proc_ptr_comp_pass_4.f90: New. + * gfortran.dg/proc_ptr_comp_pass_5.f90: New. + * gfortran.dg/typebound_call_10.f03: New. + 2009-07-24 Jason Merrill * g++.dg/cpp0x/defaulted11.C: New. diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 index 34c27f3..74dd4b8 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 @@ -16,7 +16,6 @@ end interface external :: aaargh type :: t - procedure(sub), pointer :: ptr1 ! { dg-error "not yet implemented" } procedure(real), pointer, nopass :: ptr2 procedure(sub), pointer, nopass :: ptr3 procedure(), pointer, nopass ptr4 ! { dg-error "Expected '::'" } @@ -29,6 +28,10 @@ type :: t real :: y end type t +type,bind(c) :: bct ! { dg-error "BIND.C. derived type" } + procedure(), pointer,nopass :: ptr ! { dg-error "cannot be a member of|may not be C interoperable" } +end type bct + procedure(sub), pointer :: pp type(t) :: x diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90 new file mode 100644 index 0000000..14a21ec --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! FIXME: Remove -w after polymorphic entities are supported. +! { dg-options "-w" } +! +! PR 39630: [F03] Procedure Pointer Components with PASS +! +! found at http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/4a827e8ced6efb0f/884b9eca6d7e6742 + +module mymod + + type :: mytype + integer :: i + procedure(set_int_value), pointer :: seti + end type + + abstract interface + subroutine set_int_value(this,i) + import + type(mytype), intent(inout) :: this + integer, intent(in) :: i + end subroutine set_int_value + end interface + + contains + + subroutine seti_proc(this,i) + type(mytype), intent(inout) :: this + integer, intent(in) :: i + this%i=i + end subroutine seti_proc + +end module mymod + +program Test_03 + use mymod + implicit none + + type(mytype) :: m + + m%i = 44 + m%seti => seti_proc + + call m%seti(6) + + if (m%i/=6) call abort() + +end program Test_03 + +! { dg-final { cleanup-modules "mymod" } } + diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90 new file mode 100644 index 0000000..c6671a6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! FIXME: Remove -w after polymorphic entities are supported. +! { dg-options "-w" } +! +! PR 39630: [F03] Procedure Pointer Components with PASS +! +! taken from "The Fortran 2003 Handbook" (Adams et al., 2009) + +module passed_object_example + + type t + real :: a + procedure(print_me), pointer, pass(arg) :: proc + end type t + +contains + + subroutine print_me (arg, lun) + type(t), intent(in) :: arg + integer, intent(in) :: lun + if (abs(arg%a-2.718)>1E-6) call abort() + write (lun,*) arg%a + end subroutine print_me + + subroutine print_my_square (arg, lun) + type(t), intent(in) :: arg + integer, intent(in) :: lun + if (abs(arg%a-2.718)>1E-6) call abort() + write (lun,*) arg%a**2 + end subroutine print_my_square + +end module passed_object_example + + +program main + use passed_object_example + use iso_fortran_env, only: output_unit + + type(t) :: x + + x%a = 2.718 + x%proc => print_me + call x%proc (output_unit) + x%proc => print_my_square + call x%proc (output_unit) + +end program main + +! { dg-final { cleanup-modules "passed_object_example" } } + diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90 new file mode 100644 index 0000000..15a0904 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! FIXME: Remove -w after polymorphic entities are supported. +! { dg-options "-w" } +! +! PR 39630: [F03] Procedure Pointer Components with PASS +! +! taken from "Fortran 95/2003 explained" (Metcalf, Reid, Cohen, 2004) + +type t + procedure(obp), pointer, pass(x) :: p + character(100) :: name +end type + +abstract interface + subroutine obp(w,x) + import :: t + integer :: w + type(t) :: x + end subroutine +end interface + +type(t) :: a +a%p => my_obp_sub +a%name = "doodoo" + +call a%p(32) + +contains + + subroutine my_obp_sub(w,x) + integer :: w + type(t) :: x + if (x%name/="doodoo") call abort() + if (w/=32) call abort() + end subroutine + +end + diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90 new file mode 100644 index 0000000..b52c810 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90 @@ -0,0 +1,75 @@ +! { dg-do compile } +! +! PR 39630: [F03] Procedure Pointer Components with PASS +! +! Contributed by Janus Weil + +module m + + type :: t0 + procedure() :: p0 ! { dg-error "POINTER attribute is required for procedure pointer component" } + end type + + type :: t1 + integer :: i + procedure(foo1), pointer :: f1 ! { dg-error "must be scalar" } + end type + + type :: t2 + integer :: i + procedure(foo2), pointer :: f2 ! { dg-error "may not have the POINTER attribute" } + end type + + type :: t3 + integer :: i + procedure(foo3), pointer :: f3 ! { dg-error "may not be ALLOCATABLE" } + end type + + type :: t4 + procedure(), pass(x), pointer :: f4 ! { dg-error "NOPASS or explicit interface required" } + procedure(real), pass(y), pointer :: f5 ! { dg-error "NOPASS or explicit interface required" } + procedure(foo6), pass(c), pointer :: f6 ! { dg-error "has no argument" } + end type + + type :: t7 + procedure(foo7), pass, pointer :: f7 ! { dg-error "must have at least one argument" } + end type + + type :: t8 + procedure(foo8), pass, pointer :: f8 ! { dg-error "must be of the derived type" } + end type + +contains + + subroutine foo1 (x1,y1) + type(t1) :: x1(:) + type(t1) :: y1 + end subroutine + + subroutine foo2 (x2,y2) + type(t2),pointer :: x2 + type(t2) :: y2 + end subroutine + + subroutine foo3 (x3,y3) ! { dg-error "may not be ALLOCATABLE" } + type(t3),allocatable :: x3 + type(t3) :: y3 + end subroutine + + real function foo6 (a,b) + real :: a,b + foo6 = 1. + end function + + integer function foo7 () + foo7 = 2 + end function + + character function foo8 (i) + integer :: i + end function + +end module m + +! { dg-final { cleanup-modules "m" } } + diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_5.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_5.f90 new file mode 100644 index 0000000..216a554 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_5.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! PR 39630: [F03] Procedure Pointer Components with PASS +! +! Contributed by Tobias Burnus + +module m + type :: t + sequence + integer :: i + procedure(foo), pointer,pass(y) :: foo + end type t +contains + subroutine foo(x,y) + type(t),optional :: x + type(t) :: y + if(present(x)) then + print *, 'foo', x%i, y%i + if (mod(x%i+y%i,3)/=2) call abort() + else + print *, 'foo', y%i + if (mod(y%i,3)/=1) call abort() + end if + end subroutine foo +end module m + +use m +type(t) :: t1, t2 +t1%i = 4 +t2%i = 7 +t1%foo => foo +t2%foo => t1%foo +call t1%foo() +call t2%foo() +call t2%foo(t1) +end + +! { dg-final { cleanup-modules "m" } } + diff --git a/gcc/testsuite/gfortran.dg/typebound_call_10.f03 b/gcc/testsuite/gfortran.dg/typebound_call_10.f03 new file mode 100644 index 0000000..29b6401 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_call_10.f03 @@ -0,0 +1,42 @@ +! { dg-do run } +! +! FIXME: Remove -w after polymorphic entities are supported. +! { dg-options "-w" } +! +! PR 39630: [F03] Procedure Pointer Components with PASS +! +! Contributed by Tobias Burnus + +module m + + type :: t + integer :: i + contains + procedure, pass(y) :: foo + end type t + +contains + + subroutine foo(x,y) + type(t),optional :: x + type(t) :: y + if(present(x)) then + print *, 'foo', x%i, y%i + else + print *, 'foo', y%i + end if + end subroutine foo + +end module m + +use m +type(t) :: t1, t2 +t1%i = 3 +t2%i = 4 +call t1%foo() +call t2%foo() +call t1%foo(t2) +end + +! { dg-final { cleanup-modules "m" } } +