Re: [PATCH, Fortran] PROCEDURE declarations

["Janus Weil" <jaydub66 at googlemail dot com>]

Hi Tobi,
thanks for your very thorough Saturday-night review :)
I've already finished a part of your suggestions, but some need discussion.


> Actually, I think it would make even more sense to introduce two
> different statement types, say ST_PROCEDURE (R1206) and
> ST_PROCEDURE_DECL (R1211).  Then distinguish between the two in
> decode_statement by the opening parentheses required in R1211.  This
> would allow you to put fit the check whether the statement is allowed
> into parse.c's provisions.

Well, ok, one *could* do this. OTOH the code seems perfectly clear to
me as it is, and I'm not quite convinced to change this. In
particular, if we implement the remaining bits of the PROCEDURE syntax
(R445 and R451), then we have two more cases. And these cannot be
distinguished by opening parentheses, but only by context, i.e. with
"gfc_current_state" as I do now. But if you insist (and give me some
good reasons), I'll do it.


> > +   /* TODO: Implement procedure pointers.  */
> > +  if (attr->procedure && attr->pointer)
> > +    {
> > +      gfc_error ("Procedure pointers used at %L are "
> > +             "not yet implemented", where);
> > +      return FAILURE;
> > +    }
> > +
>
> The wording should make very explicit that this is a compiler
> deficiency, maybe use "sorry"?  I also feel that this is an omission
> that limits the usefulness of this language feature by quite a lot, but
> I only started reading about F2K's features, so I may be misestimating.

The words "not yet implemented" to my ears do sound like a compiler
deficiency. And to be honest I don't feel like I have to apologize to
the user for not having implemented some feature. If I would, then
each ifort error message should start like "I'm sorry I suck so hard
at F2003" ;)
Seriously though, I'm now using your recent suggestion "Fortran 2003:
procedure pointers at %L are not yet implemented in gfortran.".

And ok, surely I would *like* to have procedure pointers implemented.
But for now I am happy that basic PROCEDURE statements are working.
Better than nothing, don't you think?


> > +{
> > +  match m;
> > +  locus old_loc, entry_loc;
>
> The naming of the variable reminds me: you should add testcases that
> everything works with ENTRYs, they have a tendency of breaking
> assumptions everywhere.

I don't see how ENTRYs could break the patch. Do you have an example?


> > +  /* Various interface checks.  */
>
> Move them to a gfc_add_procedure function in symbol.c.
> > +  if (proc_if)
> > +    {
> > +      if (proc_if->generic)
> > +     {
> > +       gfc_error ("Interface '%s' at %C may not be generic", proc_if->name);
> > +       return MATCH_ERROR;
> > +     }
> > +      if (proc_if->attr.proc == PROC_ST_FUNCTION)
> > +     {
> > +       gfc_error ("Interface '%s' at %C may not be a statement function",
> > +                 proc_if->name);
> > +       return MATCH_ERROR;
> > +     }
>
> This particular case should be picked up by the call to check_conflict
> in your new gfc_add_procedure().

There already is a "gfc_add_procedure" which sets the sym->attr.proc
field, i.e. does something different than needed here. So should I
create a new function called "gfc_add_proc"?


> > +      /* TODO: Allow intrinsics with gfc_intrinsic_actual_ok (proc_if->name, 0)
> > +      after PR33162 is fixed.  */
> > +      if (proc_if->attr.intrinsic)
> > +     {
> > +       gfc_error ("Intrinsic procedure '%s' not yet supported "
> > +                 "in PROCEDURE statement at %C", proc_if->name);
> > +       return MATCH_ERROR;
> > +     }
> > +    }
>
> Again, make clear that this is a compiler deficiency.  People may wonder
> if "not yet supported" may mean "at a later point in the program, this
> would work".

I think Tobi B's suggestion to use "not yet implemented" sounds like
the intrinsic procedure as such is not implemented. Any other ideas?
Maybe we just leave out the "yet"? This avoids confusion with "later
in the program ..", and says that it's not supported (i.e. by the
compiler), even though it's defined in the standard.


> > +  /* Get procedure symbols.  */
> > +  for(num=1;;num++)
>
> I'm wondering if there's a more C-ish way of writing this, num is not at
> all related to the loop logic.

Right, it's just counting the number of identifiers. But in a more
compact way than

> num = 0;
> do
>    {
>       num++;
>       ...
>    }
> while (1);
>
> Actually, looking over the code in set_binding_label(), this counting
> stuff is misleading: it is only needed to see if there are multiple
> identifiers associated with the same C name.  I.e. this stuff could be
> reworked to use a boolean flag, modifying set_binding_label() and its
> callers along the way, i.e. this would look like
> only_idetifier = truee;
> do
>    {
>      ...
>      set_binding_label (..., flag);
>      flag = false;
>    }
> while (1);

Well, this whole thing was not my idea. I'm just using the
implementation of set_binding_label.

> Another solution would be to move this particular check to the
> resolution stage.  While even cleaner, this also would mean more work
> for you.

But at resolution stage we have no information of the number of
identifiers, do we?


> > +      /* Set interface.  */
> > +      if (proc_if != NULL)
> > +     sym->interface = proc_if;
> > +      else if (current_ts.type != BT_UNKNOWN)
> > +     {
> > +       sym->interface = gfc_new_symbol ("", gfc_current_ns);
> > +       sym->interface->ts = current_ts;
> > +       sym->interface->attr.function = 1;
> > +       sym->ts = sym->interface->ts;
> > +       sym->attr.function = sym->interface->attr.function;
> > +     }
> > +
> > +      if (sym->interface && sym->interface->attr.if_source)
> > +     {
> > +       sym->ts = sym->interface->ts;
> > +       sym->attr.function = sym->interface->attr.function;
> > +       sym->attr.subroutine = sym->interface->attr.subroutine;
> > +       copy_formal_args (sym, sym->interface);
> > +     }
>
> I take it there can be no overlap between the last case of the first if,
> and the second if?  Then this should be an else if.  Otherwise, the code
> is confusing, as flags may be set and reset along the way.

As you mentioned below, the same code occurs in resolve_symbol. I was
not sure if it would be needed at this point, therefore the
redundancy. Apparently it's not needed and I'll remove it.


> Perhaps due to our (IMO braindead) use of tabs and it's interactions
> with quoting and the patch format in my mailreader, in the following
> your indentation constantly seems to be off by one.
>
> > +  for(;;)
> > +    {
> > +      m = gfc_match_name (name);
> > +      if (m == MATCH_NO)
> > +     goto syntax;
> > +      if (m != MATCH_YES)
> > +     return MATCH_ERROR;

I guess this is due to your mailreader. I think my indentation is fine.

The new patch is attached, regtested as usual.
Cheers,
Janus



2007-09-02  Janus Weil  <jaydub66@gmail.com>
	    Paul Thomas  <pault@gcc.gnu.org>

	* decl.c (match_procedure_decl,match_procedure_in_interface,
	gfc_match_procedure): Handle PROCEDURE statements.
	* gfortran.h (struct gfc_symbol): New member "gfc_symbol *interface".
	(enum gfc_statement): New element "ST_PROCEDURE".
	(strcut symbol_attribute): New member "unsigned procedure".
	* interface.c (check_interface0): Extended error checking.
	* match.h: Add gfc_match_procedure prototype.
	* parse.c (decode_statement,next_statement,gfc_ascii_statement,
	parse_derived,parse_interface): Implement PROCEDURE statements.
	* resolve.c (resolve_symbol): Ditto.
	* symbol.c (check_conflict): Ditto.
	(copy_formal_args): New function for copying formal argument lists.


2007-09-02  Janus Weil  <jaydub66@gmail.com>
	    Tobias Burnus  <burnus@net-b.de>

	* gfortran.dg/proc_decl_1.f90: New.
	* gfortran.dg/proc_decl_2.f90: New.
	* gfortran.dg/proc_decl_3.f90: New.
	* gfortran.dg/proc_decl_4.f90: New.

Index: gcc/testsuite/gfortran.dg/proc_decl_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_4.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/proc_decl_4.f90	(revision 0)
@@ -0,0 +1,10 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+! Test for PROCEDURE statements with the -std=f95 flag.
+! Contributed by Janus Weil <jaydub66@gmail.com>
+
+program p
+
+procedure():: proc  ! { dg-error "Fortran 2003: PROCEDURE statement" }
+
+end program 
Index: gcc/testsuite/gfortran.dg/proc_decl_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_1.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/proc_decl_1.f90	(revision 0)
@@ -0,0 +1,67 @@
+! { dg-do compile }
+! This tests various error messages for PROCEDURE declarations.
+! Contributed by Janus Weil <jaydub66@gmail.com>
+
+module m
+
+  abstract interface
+    subroutine sub()
+    end subroutine
+    subroutine sub2() bind(c)
+    end subroutine
+  end interface
+
+  procedure(), public, private :: a  ! { dg-error "was already specified" }
+  procedure(sub),bind(C) :: a2  ! { dg-error "requires an interface with BIND.C." }
+  procedure(sub2), public, bind(c, name="myEF") :: e, f  ! { dg-error "Multiple identifiers provided with single NAME= specifier" }
+  procedure(sub2), bind(C, name=""), pointer :: g  ! { dg-error "may not have POINTER attribute" }
+
+  public:: h
+  procedure(),public:: h  ! { dg-error "was already specified" }
+
+end module m
+
+
+program prog
+
+  interface z
+    subroutine z1()
+    end subroutine
+    subroutine z2(a)
+      integer :: a
+    end subroutine
+  end interface
+
+  procedure(z) :: bar	  ! { dg-error "may not be generic" }
+
+  procedure(), allocatable:: b  ! { dg-error "PROCEDURE attribute conflicts with ALLOCATABLE attribute" }
+  procedure(), save:: c  ! { dg-error "PROCEDURE attribute conflicts with SAVE attribute" }
+
+  procedure(dcos) :: my1  ! { dg-error "not yet supported in PROCEDURE statement" }
+  procedure(amax0) :: my2  ! { dg-error "not allowed in PROCEDURE statement" }
+
+  procedure(),pointer:: ptr  ! { dg-error "not yet implemented" }
+
+  type t
+    procedure(),pointer:: p  ! { dg-error "not yet implemented" }
+  end type
+
+  real f, x
+  f(x) = sin(x**2)
+  external oo
+
+  procedure(f) :: q  ! { dg-error "may not be a statement function" }
+  procedure(oo) :: p  ! { dg-error "must be explicit" }
+
+contains
+
+  subroutine foo(a,c)
+    abstract interface
+      subroutine b() bind(C)
+      end subroutine b
+    end interface
+    procedure(b), bind(c,name="hjj") :: a  ! { dg-error "may not have BIND.C. attribute with NAME" }
+    procedure(c),intent(in):: c  ! { dg-error "PROCEDURE attribute conflicts with INTENT attribute" }
+  end subroutine foo 
+
+end program
Index: gcc/testsuite/gfortran.dg/proc_decl_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_2.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/proc_decl_2.f90	(revision 0)
@@ -0,0 +1,128 @@
+! { dg-do run }
+! Various runtime tests of PROCEDURE declarations.
+! Contributed by Janus Weil <jaydub66@gmail.com>
+
+module m
+
+  abstract interface
+    subroutine csub() bind(c)
+    end subroutine csub
+  end interface
+
+  procedure():: mp1
+  procedure(real), private:: mp2
+  procedure(mfun), public:: mp3
+  procedure(csub), public, bind(c) :: c, d
+  procedure(csub), public, bind(c, name="myB") :: b
+
+contains
+
+  real function mfun(x,y)
+    real x,y
+    mfun=4.2
+  end function
+
+  subroutine bar(a,b)
+    implicit none
+    interface
+      subroutine a()
+      end subroutine a
+    end interface
+    optional ::  a
+    procedure(a), optional :: b
+  end subroutine bar
+
+end module
+
+
+program p
+  implicit none
+
+  abstract interface
+    subroutine abssub(x)
+      real x
+    end subroutine
+  end interface
+
+  integer i
+  real r
+
+  procedure(integer):: p1
+  procedure(fun):: p2
+  procedure(abssub):: p3
+  procedure(sub):: p4
+  procedure():: p5
+  procedure(p4):: p6
+  procedure(integer) :: p7
+
+  i=p1()
+  if (i /= 5) call abort()
+  i=p2(3.1)
+  if (i /= 3) call abort()
+  r=4.2
+  call p3(r)
+  if (abs(r-5.2)>1e-6) call abort()
+  call p4(r)
+  if (abs(r-3.7)>1e-6) call abort()
+  call p5()
+  call p6(r)
+  if (abs(r-7.4)>1e-6) call abort()
+  i=p7(4)
+  if (i /= -8) call abort()
+  r=dummytest(p3)
+  if (abs(r-2.1)>1e-6) call abort()
+
+contains
+
+  integer function fun(x)
+    real x
+    fun=7
+  end function
+
+  subroutine sub(x)
+    real x
+  end subroutine
+
+  real function dummytest(dp)
+    procedure(abssub):: dp
+    real y
+    y=1.1
+    call dp(y)
+    dummytest=y
+  end function
+
+end program p
+
+
+integer function p1()
+  p1 = 5
+end function
+
+integer function p2(x)
+  real x
+  p2 = int(x)
+end function
+
+subroutine p3(x)
+  real,intent(inout):: x
+  x=x+1.0
+end subroutine
+
+subroutine p4(x)
+  real,intent(inout):: x
+  x=x-1.5
+end subroutine
+
+subroutine p5()
+end subroutine
+
+subroutine p6(x)
+  real,intent(inout):: x
+  x=x*2.
+end subroutine
+
+function p7(x)
+ implicit none
+ integer :: x, p7
+ p7 = x*(-2)
+end function
Index: gcc/testsuite/gfortran.dg/proc_decl_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_3.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/proc_decl_3.f90	(revision 0)
@@ -0,0 +1,75 @@
+! { dg-do compile }
+! Some tests for PROCEDURE declarations inside of interfaces.
+! Contributed by Janus Weil <jaydub66@gmail.com>
+
+module m
+
+  interface
+    subroutine a()
+    end subroutine a
+  end interface
+
+  procedure(c) :: f
+
+  interface bar
+    procedure a,d
+  end interface bar
+
+  interface foo
+    procedure c
+  end interface foo
+
+  abstract interface
+    procedure f  ! { dg-error "must be in a generic interface" }
+  end interface
+
+  interface
+    function opfoo(a)
+      integer,intent(in) :: a
+      integer :: opfoo
+    end function opfoo
+  end interface
+
+  interface operator(.op.)
+    procedure opfoo
+  end interface
+
+  external ex  ! { dg-error "has no explicit interface" }
+  procedure():: ip  ! { dg-error "has no explicit interface" }
+  procedure(real):: pip  ! { dg-error "has no explicit interface" }
+
+  interface nn1
+    procedure ex
+    procedure a, a  ! { dg-error "already present in the interface" }
+  end interface
+
+  interface nn2
+    procedure ip
+  end interface
+
+  interface nn3
+    procedure pip
+  end interface
+
+contains
+
+ subroutine d(x)
+
+   interface
+     subroutine x()
+     end subroutine x
+   end interface
+
+   interface gen
+     procedure x
+   end interface
+
+ end subroutine d
+
+ function c(x)
+   integer :: x
+   real :: c
+   c = 3.4*x
+ end function c
+
+end module m
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 128023)
+++ gcc/fortran/interface.c	(working copy)
@@ -986,7 +986,7 @@ check_interface0 (gfc_interface *p, cons
   /* Make sure all symbols in the interface have been defined as
      functions or subroutines.  */
   for (; p; p = p->next)
-    if (!p->sym->attr.function && !p->sym->attr.subroutine)
+    if ((!p->sym->attr.function && !p->sym->attr.subroutine) || !p->sym->attr.if_source)
       {
 	if (p->sym->attr.external)
 	  gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 128023)
+++ gcc/fortran/symbol.c	(working copy)
@@ -352,7 +352,7 @@ check_conflict (symbol_attribute *attr, 
     *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
     *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
     *volatile_ = "VOLATILE", *protected = "PROTECTED",
-    *is_bind_c = "BIND(C)";
+    *is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
   static const char *threadprivate = "THREADPRIVATE";
 
   const char *a1, *a2;
@@ -438,7 +438,7 @@ check_conflict (symbol_attribute *attr, 
 
   conf (external, intrinsic);
 
-  if (attr->if_source || attr->contained)
+  if ((attr->if_source && !attr->procedure) || attr->contained)
     {
       conf (external, subroutine);
       conf (external, function);
@@ -545,6 +545,21 @@ check_conflict (symbol_attribute *attr, 
       goto conflict;
     }
 
+  conf (procedure, allocatable)
+  conf (procedure, dimension)
+  conf (procedure, intrinsic)
+  conf (procedure, protected)
+  conf (procedure, target)
+  conf (procedure, value)
+  conf (procedure, volatile_)
+   /* TODO: Implement procedure pointers.  */
+  if (attr->procedure && attr->pointer)
+    {
+      gfc_error ("Fortran 2003: Procedure pointers at %L are "
+		"not yet implemented in gfortran", where);
+      return FAILURE;
+    }
+
   a1 = gfc_code2string (flavors, attr->flavor);
 
   if (attr->in_namelist
@@ -3532,6 +3547,61 @@ add_proc_interface (gfc_symbol *sym, ifs
   sym->attr.if_source = source;
 }
 
+/* Copy the formal args from an existing symbol, src, into a new
+   symbol, dest.  New formal args are created, and the description of
+   each arg is set according to the existing ones.  This function is
+   used when creating procedure declaration variables from a procedure
+   declaration statement (see match_proc_decl()) to create the formal
+   args based on the args of a given named interface.  */
+
+void copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
+{
+  gfc_formal_arglist *head = NULL;
+  gfc_formal_arglist *tail = NULL;
+  gfc_formal_arglist *formal_arg = NULL;
+  gfc_formal_arglist *curr_arg = NULL;
+  gfc_formal_arglist *formal_prev = NULL;
+  /* Save current namespace so we can change it for formal args.  */
+  gfc_namespace *parent_ns = gfc_current_ns;
+
+  /* Create a new namespace, which will be the formal ns (namespace
+     of the formal args).  */
+  gfc_current_ns = gfc_get_namespace (parent_ns, 0);
+  gfc_current_ns->proc_name = dest;
+
+  for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+    {
+      formal_arg = gfc_get_formal_arglist ();
+      gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
+
+      /* May need to copy more info for the symbol.  */
+      formal_arg->sym->attr = curr_arg->sym->attr;
+      formal_arg->sym->ts = curr_arg->sym->ts;
+
+      /* If this isn't the first arg, set up the next ptr.  For the
+        last arg built, the formal_arg->next will never get set to
+        anything other than NULL.  */
+      if (formal_prev != NULL)
+	formal_prev->next = formal_arg;
+      else
+	formal_arg->next = NULL;
+
+      formal_prev = formal_arg;
+
+      /* Add arg to list of formal args.  */
+      add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+    }
+
+  /* Add the interface to the symbol.  */
+  add_proc_interface (dest, IFSRC_DECL, head);
+
+  /* Store the formal namespace information.  */
+  if (dest->formal != NULL)
+    /* The current ns should be that for the dest proc.  */
+    dest->formal_ns = gfc_current_ns;
+  /* Restore the current namespace to what it was on entry.  */
+  gfc_current_ns = parent_ns;
+}
 
 /* Builds the parameter list for the iso_c_binding procedure
    c_f_pointer or c_f_procpointer.  The old_sym typically refers to a
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 128023)
+++ gcc/fortran/decl.c	(working copy)
@@ -3633,6 +3633,248 @@ gfc_match_suffix (gfc_symbol *sym, gfc_s
 }
 
 
+/* Match a PROCEDURE declaration (R1211).  */
+
+static match
+match_procedure_decl (void)
+{
+  match m;
+  locus old_loc, entry_loc;
+  gfc_symbol *sym, *proc_if = NULL;
+  int num;
+
+  old_loc = entry_loc = gfc_current_locus;
+
+  gfc_clear_ts (&current_ts);
+
+  if (gfc_match (" (") != MATCH_YES)
+    {
+      gfc_current_locus = entry_loc;
+      return MATCH_NO;
+    }
+
+  /* Get the type spec. for the procedure interface.  */
+  old_loc = gfc_current_locus;
+  m = match_type_spec (&current_ts, 0);
+  if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_char () == ')'))
+    goto got_ts;
+
+  if (m == MATCH_ERROR)
+    return m;
+
+  gfc_current_locus = old_loc;
+
+  /* Get the name of the procedure or abstract interface
+  to inherit the interface from.  */
+  m = gfc_match_symbol (&proc_if, 1);
+
+  if (m == MATCH_NO)
+    goto syntax;
+  else if (m == MATCH_ERROR)
+    return m;
+
+  /* Various interface checks.  */
+  if (proc_if)
+    {
+      if (proc_if->generic)
+	{
+	  gfc_error ("Interface '%s' at %C may not be generic", proc_if->name);
+	  return MATCH_ERROR;
+	}
+      if (proc_if->attr.proc == PROC_ST_FUNCTION)
+	{
+	  gfc_error ("Interface '%s' at %C may not be a statement function",
+		    proc_if->name);
+	  return MATCH_ERROR;
+	}
+      /* Handle intrinsic procedures.  */
+      if (gfc_intrinsic_name (proc_if->name, 0)
+	  || gfc_intrinsic_name (proc_if->name, 1))
+	proc_if->attr.intrinsic = 1;
+      if (proc_if->attr.intrinsic
+	  && !gfc_intrinsic_actual_ok (proc_if->name, 0))
+	{
+	  gfc_error ("Intrinsic procedure '%s' not allowed "
+		    "in PROCEDURE statement at %C", proc_if->name);
+	  return MATCH_ERROR;
+	}
+      /* TODO: Allow intrinsics with gfc_intrinsic_actual_ok (proc_if->name, 0)
+      after PR33162 is fixed.  */
+      if (proc_if->attr.intrinsic)
+	{
+	  gfc_error ("Intrinsic procedure '%s' not yet supported "
+		    "in PROCEDURE statement at %C", proc_if->name);
+	  return MATCH_ERROR;
+	}
+    }
+
+got_ts:
+
+  if (gfc_match (" )") != MATCH_YES)
+    {
+      gfc_current_locus = entry_loc;
+      return MATCH_NO;
+    }
+
+  /* Parse attributes.  */
+  m = match_attr_spec();
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  /* Get procedure symbols.  */
+  for(num=1;;num++)
+    {
+
+      m = gfc_match_symbol (&sym, 0);
+      if (m == MATCH_NO)
+	goto syntax;
+      else if (m == MATCH_ERROR)
+	return m;
+
+      /* Add current_attr to the symbol attributes.  */
+      if (gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
+	return MATCH_ERROR;
+
+      sym->attr.procedure = 1;
+
+      if (sym->attr.is_bind_c)
+	{
+	  /* Check for C1218.  */
+	  if (!proc_if || !proc_if->attr.is_bind_c)
+	    {
+	      gfc_error ("BIND(C) attribute at %C requires "
+			"an interface with BIND(C)");
+	      return MATCH_ERROR;
+	    }
+	  /* Check for C1217.  */
+	  if (has_name_equals && sym->attr.pointer)
+	    {
+	      gfc_error ("BIND(C) procedure with NAME may not have "
+			"POINTER attribute at %C");
+	      return MATCH_ERROR;
+	    }
+	  if (has_name_equals && sym->attr.dummy)
+	    {
+	      gfc_error ("Dummy procedure at %C may not have "
+			"BIND(C) attribute with NAME");
+	      return MATCH_ERROR;
+	    }
+	  /* Set binding label for BIND(C).  */
+	  if (set_binding_label (sym->binding_label, sym->name, num) != SUCCESS)
+	    return MATCH_ERROR;
+	}
+
+      if (!sym->attr.pointer && gfc_add_external (&sym->attr, NULL) == FAILURE)
+	return MATCH_ERROR;
+      if (gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
+	return MATCH_ERROR;
+
+      /* Set interface.  */
+      if (proc_if != NULL)
+	sym->interface = proc_if;
+      else if (current_ts.type != BT_UNKNOWN)
+	{
+	  sym->interface = gfc_new_symbol ("", gfc_current_ns);
+	  sym->interface->ts = current_ts;
+	  sym->interface->attr.function = 1;
+	  sym->ts = sym->interface->ts;
+	  sym->attr.function = sym->interface->attr.function;
+	}
+
+      if (gfc_match_eos () == MATCH_YES)
+	return MATCH_YES;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+syntax:
+  gfc_error ("Syntax error in PROCEDURE statement at %C");
+  return MATCH_ERROR;
+}
+
+
+/* Match a PROCEDURE declaration inside an interface (R1206).  */
+
+static match
+match_procedure_in_interface (void)
+{
+  match m;
+  gfc_symbol *sym;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+
+  if (current_interface.type == INTERFACE_NAMELESS
+      || current_interface.type == INTERFACE_ABSTRACT)
+    {
+      gfc_error ("PROCEDURE at %C must be in a generic interface");
+      return MATCH_ERROR;
+    }
+
+  for(;;)
+    {
+      m = gfc_match_name (name);
+      if (m == MATCH_NO)
+	goto syntax;
+      else if (m == MATCH_ERROR)
+	return m;
+      if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
+	return MATCH_ERROR;
+
+      if (gfc_add_interface (sym) == FAILURE)
+	return MATCH_ERROR;
+
+      sym->attr.procedure = 1;
+
+      if (gfc_match_eos () == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in PROCEDURE statement at %C");
+  return MATCH_ERROR;
+}
+
+
+/* General matcher for PROCEDURE declarations.  */
+
+match
+gfc_match_procedure (void)
+{
+  match m;
+
+  switch (gfc_current_state ())
+    {
+    case COMP_NONE:
+    case COMP_PROGRAM:
+    case COMP_MODULE:
+    case COMP_SUBROUTINE:
+    case COMP_FUNCTION:
+      m = match_procedure_decl ();
+      break;
+    case COMP_INTERFACE:
+      m = match_procedure_in_interface ();
+      break;
+    case COMP_DERIVED:
+      gfc_error ("Procedure components used at %C are not yet implemented");
+      return MATCH_ERROR;
+    default:
+      return MATCH_NO;
+    }
+
+  if (m != MATCH_YES)
+    return m;
+
+  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROCEDURE statement at %C")
+      == FAILURE)
+    return MATCH_ERROR;
+
+  return m;
+}
+
+
 /* Match a function declaration.  */
 
 match
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 128023)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -245,7 +245,7 @@ typedef enum
   ST_OMP_END_WORKSHARE, ST_OMP_DO, ST_OMP_FLUSH, ST_OMP_MASTER, ST_OMP_ORDERED,
   ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
   ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE,
-  ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE,
+  ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_PROCEDURE,
   ST_NONE
 }
 gfc_statement;
@@ -644,7 +644,8 @@ typedef struct
     imported:1;			/* Symbol has been associated by IMPORT.  */
 
   unsigned in_namelist:1, in_common:1, in_equivalence:1;
-  unsigned function:1, subroutine:1, generic:1, generic_copy:1;
+  unsigned function:1, subroutine:1, procedure:1;
+  unsigned generic:1, generic_copy:1;
   unsigned implicit_type:1;	/* Type defined via implicit rules.  */
   unsigned untyped:1;           /* No implicit type could be found.  */
 
@@ -1016,6 +1017,8 @@ typedef struct gfc_symbol
   struct gfc_symbol *result;	/* function result symbol */
   gfc_component *components;	/* Derived type components */
 
+  struct gfc_symbol *interface;	/* For PROCEDURE declarations.  */
+
   /* Defined only for Cray pointees; points to their pointer.  */
   struct gfc_symbol *cp_pointer;
 
@@ -2165,6 +2168,8 @@ void gfc_symbol_state (void);
 gfc_gsymbol *gfc_get_gsymbol (const char *);
 gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
 
+void copy_formal_args (gfc_symbol *dest, gfc_symbol *src);
+
 /* intrinsic.c */
 extern int gfc_init_expr;
 
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 128023)
+++ gcc/fortran/resolve.c	(working copy)
@@ -7362,6 +7362,25 @@ resolve_symbol (gfc_symbol *sym)
 	}
     }
 
+  if (sym->attr.procedure && sym->interface
+      && sym->attr.if_source != IFSRC_DECL)
+    {
+      /* Get the attributes from the interface (now resolved).  */
+      if (sym->interface->attr.if_source || sym->interface->attr.intrinsic)
+	{
+	  sym->ts = sym->interface->ts;
+	  sym->attr.function = sym->interface->attr.function;
+	  sym->attr.subroutine = sym->interface->attr.subroutine;
+	  copy_formal_args (sym, sym->interface);
+	}
+      else if (sym->interface->name[0] != '\0')
+	{
+	  gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
+		    sym->interface->name, sym->name, &sym->declared_at);
+	  return;
+	}
+    }
+
   if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
     return;
 
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h	(revision 128023)
+++ gcc/fortran/match.h	(working copy)
@@ -134,6 +134,7 @@ match gfc_match_old_kind_spec (gfc_types
 match gfc_match_end (gfc_statement *);
 match gfc_match_data_decl (void);
 match gfc_match_formal_arglist (gfc_symbol *, int, int);
+match gfc_match_procedure (void);
 match gfc_match_function_decl (void);
 match gfc_match_entry (void);
 match gfc_match_subroutine (void);
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c	(revision 128023)
+++ gcc/fortran/parse.c	(working copy)
@@ -258,6 +258,7 @@ decode_statement (void)
       match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
       if (gfc_match_private (&st) == MATCH_YES)
 	return st;
+      match ("procedure", gfc_match_procedure, ST_PROCEDURE);
       match ("program", gfc_match_program, ST_PROGRAM);
       if (gfc_match_public (&st) == MATCH_YES)
 	return st;
@@ -719,7 +720,8 @@ next_statement (void)
 
 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
   case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
-  case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE
+  case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
+  case ST_PROCEDURE
 
 /* Block end statements.  Errors associated with interchanging these
    are detected in gfc_match_end().  */
@@ -1078,6 +1080,9 @@ gfc_ascii_statement (gfc_statement st)
     case ST_PROGRAM:
       p = "PROGRAM";
       break;
+    case ST_PROCEDURE:
+      p = "PROCEDURE";
+      break;
     case ST_READ:
       p = "READ";
       break;
@@ -1537,6 +1542,7 @@ parse_derived (void)
 	  unexpected_eof ();
 
 	case ST_DATA_DECL:
+	case ST_PROCEDURE:
 	  accept_statement (st);
 	  seen_component = 1;
 	  break;
@@ -1749,6 +1755,7 @@ loop:
 				  gfc_new_block->formal, NULL);
       break;
 
+    case ST_PROCEDURE:
     case ST_MODULE_PROC:	/* The module procedure matcher makes
 				   sure the context is correct.  */
       accept_statement (st);