This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [PATCH, Fortran] PROCEDURE declarations
Sorry, forgot to attach the patch. Here it is.
2007/9/4, Janus Weil <jaydub66@googlemail.com>:
> Hi all,
> here is a new version of the PROCEDURE declaration patch. It solves
> the issues with ENTRY statements we found (complete with a test case)
> and adds a new function gfc_add_proc for setting the procedure
> attribute. Regtested on i686-pc-linux-gnu.
> Ok for trunk?
> Janus
>
>
> 2007-09-03 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.
> (gfc_add_proc): New function for setting the procedure attribute.
> (copy_formal_args): New function for copying formal argument lists.
>
>
> 2007-09-03 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,77 @@
+! { 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 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
+
+
+subroutine abc
+
+ procedure() :: abc2
+
+entry abc2(x) ! { dg-error "PROCEDURE attribute conflicts with ENTRY attribute" }
+ real x
+
+end subroutine
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 128037)
+++ 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 128037)
+++ 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,22 @@ 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_)
+ conf (procedure, entry)
+ /* 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
@@ -1212,6 +1228,29 @@ gfc_add_generic (symbol_attribute *attr,
}
+try
+gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
+{
+
+ if (check_used (attr, NULL, where))
+ return FAILURE;
+
+ if (attr->flavor != FL_PROCEDURE
+ && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
+ return FAILURE;
+
+ if (attr->procedure)
+ {
+ duplicate_attr ("PROCEDURE", where);
+ return FAILURE;
+ }
+
+ attr->procedure = 1;
+
+ return check_conflict (attr, NULL, where);
+}
+
+
/* Flavors are special because some flavors are not what Fortran
considers attributes and can be reaffirmed multiple times. */
@@ -3532,6 +3571,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 128037)
+++ gcc/fortran/decl.c (working copy)
@@ -3759,6 +3759,247 @@ 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 (¤t_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 (¤t_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 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, ¤t_attr, NULL) == FAILURE)
+ 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 (!sym->attr.pointer && gfc_add_external (&sym->attr, NULL) == FAILURE)
+ return MATCH_ERROR;
+ if (gfc_add_proc (&sym->attr, 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 ("Fortran 2003: Procedure components at %C are "
+ "not yet implemented in gfortran");
+ 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 128037)
+++ 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;
@@ -2094,6 +2097,7 @@ try gfc_add_recursive (symbol_attribute
try gfc_add_function (symbol_attribute *, const char *, locus *);
try gfc_add_subroutine (symbol_attribute *, const char *, locus *);
try gfc_add_volatile (symbol_attribute *, const char *, locus *);
+try gfc_add_proc (symbol_attribute *attr, const char *name, locus *where);
try gfc_add_access (symbol_attribute *, gfc_access, const char *, locus *);
try gfc_add_is_bind_c(symbol_attribute *, const char *, locus *, int);
@@ -2165,6 +2169,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 128037)
+++ 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 128037)
+++ gcc/fortran/match.h (working copy)
@@ -133,6 +133,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 128037)
+++ 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);