procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/39630 ([F03] Procedure Pointer Components)

Browse source 
2009-07-25  Janus Weil  <janus@gcc.gnu.org>

	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  <janus@gcc.gnu.org>

	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.

From-SVN: r150078
This commit is contained in:
Janus Weil 2009-07-25 13:56:35 +02:00
parent 330b922f19
commit 90661f261c
14 changed files with 582 additions and 53 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
gcc/fortran/ChangeLog
View file

@ -1,3 +1,30 @@
2009-07-25 Janus Weil <janus@gcc.gnu.org>
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 <janus@gcc.gnu.org>
PR fortran/40822

30
gcc/fortran/decl.c
View file

@ -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 (&current_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;
}

5
gcc/fortran/gfortran.h
View file

@ -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;

60
gcc/fortran/module.c
View file

@ -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 (formal)
mio_namespace_ref (&formal->sym->ns);
else
mio_namespace_ref (&c->formal_ns);
}
else
{
mio_namespace_ref (&c->formal_ns);
/* TODO: if (c->formal_ns)
if (iomode == IO_OUTPUT)
{
c->formal_ns->proc_name = c;
c->refs++;
}*/
}
formal = c->formal;
while (formal && !formal->sym)
formal = formal->next;
mio_formal_arglist (&c->formal);
if (formal)
mio_namespace_ref (&formal->sym->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_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 ();

191
gcc/fortran/resolve.c
View file

@ -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)

9
gcc/fortran/symbol.c
View file

@ -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)

11
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,14 @@
2009-07-25 Janus Weil <janus@gcc.gnu.org>
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 <jason@redhat.com>
* g++.dg/cpp0x/defaulted11.C: New.

5
gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90
View file

@ -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

51
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90 Normal file
View file

@ -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" } }

51
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90 Normal file
View file

@ -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" } }

39
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90 Normal file
View file

@ -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

75
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90 Normal file
View file

@ -0,0 +1,75 @@
! { dg-do compile }
!
! PR 39630: [F03] Procedure Pointer Components with PASS
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
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" } }

39
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_5.f90 Normal file
View file

@ -0,0 +1,39 @@
! { dg-do run }
!
! PR 39630: [F03] Procedure Pointer Components with PASS
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
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" } }

42
gcc/testsuite/gfortran.dg/typebound_call_10.f03 Normal file
View file

@ -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 <burnus@gcc.gnu.org>
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" } }