OSDN Git Service

2009-07-25 Janus Weil <janus@gcc.gnu.org>
authorjanus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Sat, 25 Jul 2009 11:56:35 +0000 (11:56 +0000)
committerjanus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Sat, 25 Jul 2009 11:56:35 +0000 (11:56 +0000)
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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150078 138bc75d-0d04-0410-961f-82ee72b054a4

14 files changed:
gcc/fortran/ChangeLog
gcc/fortran/decl.c
gcc/fortran/gfortran.h
gcc/fortran/module.c
gcc/fortran/resolve.c
gcc/fortran/symbol.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_4.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_5.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/typebound_call_10.f03 [new file with mode: 0644]

index 5f6cf27..86f0662 100644 (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
index 0207683..392f2a5 100644 (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;
 }
 
index ce8e6fc..7792cfa 100644 (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;
 
index 425bd36..eff482c 100644 (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 (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 ();
index e09167b..aaab554 100644 (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)
index dd06e48..ec4afbe 100644 (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)
index 00dbba7..71f3ad9 100644 (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.
index 34c27f3..74dd4b8 100644 (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
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 (file)
index 0000000..14a21ec
--- /dev/null
@@ -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 (file)
index 0000000..c6671a6
--- /dev/null
@@ -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 (file)
index 0000000..15a0904
--- /dev/null
@@ -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 (file)
index 0000000..b52c810
--- /dev/null
@@ -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" } }
+
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 (file)
index 0000000..216a554
--- /dev/null
@@ -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" } }
+
diff --git a/gcc/testsuite/gfortran.dg/typebound_call_10.f03 b/gcc/testsuite/gfortran.dg/typebound_call_10.f03
new file mode 100644 (file)
index 0000000..29b6401
--- /dev/null
@@ -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" } }
+