+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
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;
if (gfc_add_proc (&c->attr, name, NULL) == FAILURE)
return MATCH_ERROR;
+ c->tb = tb;
+
/* Set interface. */
if (proc_if != NULL)
{
{
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. */
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
{
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;
}
seen_ptr = true;
- /*ba->ppc = 1;*/
continue;
}
}
goto error;
}
+ m = MATCH_YES;
+
+done:
if (ba->access == ACCESS_UNKNOWN)
ba->access = gfc_typebound_default_access;
goto error;
}
- return MATCH_YES;
+ return m;
error:
- gfc_free (ba->pass_arg);
return MATCH_ERROR;
}
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;
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. */
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;
/* 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. */
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)
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)
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 ();
}
(*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);
mio_rparen ();
}
- else
+ else if (!(*proc)->ppc)
mio_symtree_ref (&(*proc)->u.specific);
mio_rparen ();
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);
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;
}
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;
}
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);
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);
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;
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;
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)
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)
+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.
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 '::'" }
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
--- /dev/null
+! { 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" } }
+
--- /dev/null
+! { 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" } }
+
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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" } }
+
--- /dev/null
+! { 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" } }
+
--- /dev/null
+! { 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" } }
+
projects / platform / upstream / linaro-gcc.git / commitdiff