This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[PATCH, Fortran] PROCEDURE declarations


:ADDPATCH fortran:

Hi all,
attached I send you my patch for the implementation of PROCEDURE
statements, which were introduced by the Fortran 2003 standard. It is
in a way the successor to my ABSTRACT INTERFACE patch, which was
committed two weeks ago (see
http://gcc.gnu.org/ml/fortran/2007-08/msg00417.html), because
PROCEDURE statements are the only application of abstract interfaces.

This patch implements only simple PROCEDURE declarations, which act as
an extension of the EXTERNAL statement, and omits the usage of the
PROCEDURE keyword for procedure pointers and type-bound procedures
(which hopefully will follow soon).

I hope all the stuff (actual code, test cases and change log) is
formally ok, and conforming to the GCC coding standards. Also I hope
that the patch provides a solid implementation of PROCEDURE
declarations, even if I can't guarantee you that it's perfect in any
sense, and am a little afraid someone might eventually be able to
break it again (which is probably gonna be Tobias, who has been doing
an awesome job in testing the patch, and has thereby made a major
contribution to the quality of the patch. So, thanks a lot, Tobi!)

And since today is officially the last day of Google's Summer of Code,
which this project was a part of, I want to thank the whole gfortran
community for supporting me and helping me get along in GCC
development, which was completely new to me, and specially my mentor
Steven Bosscher, who made this project possible in the first place. I
also want to thank Paul Thomas, who laid the foundation for my work,
in that he gave me his early procedure patch to work with.

And even though SoC is over, I'd like to keep on working on gfortran.
In particular I would really like to implement procedure pointers or
type-bound procedures in GCC 4.3. Since there is not much time left, I
don't know if I can do any of that, but at least I will try and see
how far I can get.

But first I need this patch approved, of course. It's regression
tested on i686-pc-linux-gnu without failures. Ok for trunk?
Janus



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

	* decl.c (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".
	* match.h: Add gfc_match_procedure.
	* parse.c (decode_statement,next_statement,gfc_ascii_statement,
	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-08-31  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,62 @@
+! { 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" }
+
+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" }
+
+  type t
+    procedure():: p  ! { dg-error "must have POINTER attribute" }
+  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,119 @@
+! { 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
+
+  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()
+  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
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,65 @@
+! { 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" }
+
+ interface nn
+  procedure ex
+  procedure a, a  ! { dg-error "already present in the interface" }
+ 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/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 127956)
+++ 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 ("Procedure pointers used at %L are "
+		"not yet implemented", 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 127956)
+++ gcc/fortran/decl.c	(working copy)
@@ -3633,6 +3633,243 @@ gfc_match_suffix (gfc_symbol *sym, gfc_s
 }
 
 
+/* Match a procedure declaration.  */
+
+match
+gfc_match_procedure (void)
+{
+  gfc_symbol *sym, *proc_if = NULL;
+  locus old_loc, entry_loc;
+  match m;
+  int i,num;
+  char *src_attr,*dest_attr;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+
+  old_loc = entry_loc = gfc_current_locus;
+
+  if (gfc_current_state () != COMP_NONE
+      && gfc_current_state () != COMP_PROGRAM
+      && gfc_current_state () != COMP_MODULE
+      && gfc_current_state () != COMP_SUBROUTINE
+      && gfc_current_state () != COMP_FUNCTION
+      && gfc_current_state () != COMP_INTERFACE
+      && gfc_current_state () != COMP_DERIVED)
+    return MATCH_NO;
+
+  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROCEDURE statement at %C")
+      == FAILURE)
+    return MATCH_ERROR;
+
+  gfc_clear_ts (&current_ts);
+
+  if (gfc_current_state () == COMP_INTERFACE)
+    {
+      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;
+	}
+      goto got_attr;
+    }
+
+  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;
+
+  gfc_current_locus = old_loc;
+
+  /* Get the name of the procedure or abstract interface to inherit interface from.  */
+  m = gfc_match_symbol (&proc_if, 1);
+
+  if (m == MATCH_ERROR)
+    goto syntax;
+
+  /* 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;
+
+got_attr:
+
+  /* Get procedure symbols.  */
+  for(num=1;;num++)
+    {
+
+      if (gfc_current_state () == COMP_INTERFACE)
+	{
+	  m = gfc_match_name (name);
+	  if (m == MATCH_NO)
+	    goto syntax;
+	  if (m != MATCH_YES)
+	    return MATCH_ERROR;
+	  if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
+	    return MATCH_ERROR;
+	}
+      else
+	m = gfc_match_symbol (&sym, 0);
+
+      switch (m)
+	{
+	case MATCH_YES:
+
+	  /* Add current_attr to the symbol attributes.  */
+	  src_attr = (char *) (&(current_attr));
+	  dest_attr = (char *) (&(sym->attr));
+	  for (i = 0; i < (int) sizeof (sym->attr); i++)
+	    {
+	      *dest_attr = (*dest_attr) | (*src_attr);
+	      dest_attr++;
+	      src_attr++;
+	    }
+
+	  sym->attr.procedure = 1;
+
+	  /* Check for C449.  */
+	  if (gfc_current_state () == COMP_DERIVED && !sym->attr.pointer)
+	    {
+	      gfc_error ("Procedure component at %C must have "
+			"POINTER attribute");
+	      return MATCH_ERROR;
+	    }
+
+	  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 (gfc_current_state () == COMP_INTERFACE)
+	    {
+	      if (gfc_add_interface (sym) == FAILURE)
+		return MATCH_ERROR;
+	    }
+	  else
+	    {
+	      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->interface->attr.if_source = IFSRC_DECL;
+	    }
+
+	  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);
+	    }
+
+	  goto next_item;
+
+	case MATCH_NO:
+	  break;
+
+	case MATCH_ERROR:
+	  return MATCH_ERROR;
+	}
+
+      next_item:
+	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;
+}
+
+
 /* Match a function declaration.  */
 
 match
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 127956)
+++ 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 127956)
+++ 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
+	{
+	  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 127956)
+++ 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 127956)
+++ 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;
@@ -1749,6 +1754,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);

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]