This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: PROCEDURE declarations
Ok guys, sorry I was buggin' you. The procedure symbol really got
deallocated, because I put it into the wrong namespace.
I have sorted this out and procedures in interfaces should work now.
The new patch is attached together with some testcases.
One thing that is not yet implemented in all detail is intrinsic
procedures. Right now I'm just rejecting all intrinsic procedures in
PROCEDURE statements. But C1212 says:
"If name denotes an intrinsic procedure it shall be one that is listed
in 13.6 and not marked with a bullet (•)."
So, if I want to implement this, how could I distinguish the ones with
a bullet from those without a bullet, other than just manually going
through a list of their names? And are there intrinsic procedures
which are not listed in 13.6?
In general I am quite optimistic that all major issues are solved by
now, though. But of course there may be some details where my
implementation may not work correctly. So I would be grateful for some
more review and testing of the patch. Otherwise I hope it should be
ready for going into trunk soon ...
Cheers,
Janus
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 127848)
+++ gcc/fortran/symbol.c (working copy)
@@ -438,7 +438,7 @@ check_conflict (symbol_attribute *attr,
conf (external, intrinsic);
- if (attr->if_source || attr->contained)
+ if ((attr->if_source || attr->contained) && !attr->procedure)
{
conf (external, subroutine);
conf (external, function);
@@ -3532,6 +3532,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 127848)
+++ gcc/fortran/decl.c (working copy)
@@ -3632,6 +3632,255 @@ 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 (¤t_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 (¤t_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;
+
+ if (proc_if)
+ {
+ /* Interface must be abstract. */
+ if (proc_if->generic)
+ {
+ gfc_error ("Interface %s at %C may not be generic", 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_error ("Intrinsic procedure %s not supported "
+ "in PROCEDURE statement at %C", proc_if->name);
+ return MATCH_ERROR;
+ }
+ /* TODO: Allow those intrinsinc procedures which are
+ legal here according to C1212. */
+ }
+
+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;
+ /* Check for R1213. */
+ if (current_attr.allocatable || current_attr.dimension
+ || current_attr.external || current_attr.intrinsic
+ || current_attr.protected|| current_attr.target
+ || current_attr.value || current_attr.volatile_)
+ {
+ gfc_error ("Illegal attributes at %C");
+ return MATCH_ERROR;
+ }
+ /* Check for C1214. */
+ if (current_attr.intent && !current_attr.pointer)
+ {
+ gfc_error ("INTENT at %C requires POINTER attribute");
+ return MATCH_ERROR;
+ }
+ if (current_attr.save && !current_attr.pointer)
+ {
+ gfc_error ("SAVE at %C requires POINTER attribute");
+ return MATCH_ERROR;
+ }
+ /* Check for C1218. */
+ if (current_attr.is_bind_c && (!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 C449. */
+ if (gfc_current_state () == COMP_DERIVED && !current_attr.pointer)
+ {
+ gfc_error ("Procedure component at %C must have POINTER attribute");
+ return MATCH_ERROR;
+ }
+ /* TODO: Implement procedure pointers. */
+ if (current_attr.pointer)
+ {
+ gfc_error ("Procedure pointers used at %C are not yet implemented");
+ 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;
+
+ if (sym->attr.is_bind_c)
+ {
+ /* Check for C1217. */
+ if (curr_binding_label[0] != '\0' && sym->attr.pointer)
+ {
+ gfc_error ("BIND(C) procedure with NAME may not have "
+ "POINTER attribute at %C");
+ return MATCH_ERROR;
+ }
+ if (curr_binding_label[0] != '\0' && 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)
+ sym->attr.external = 1;
+ 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;
+ }
+
+ 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;
+#if 0
+cleanup:
+ gfc_current_locus = old_loc;
+ return m;
+#endif
+}
+
+
/* Match a function declaration. */
match
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 127848)
+++ 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;
@@ -642,7 +642,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. */
@@ -1014,6 +1015,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;
@@ -2163,6 +2166,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 127848)
+++ gcc/fortran/resolve.c (working copy)
@@ -1440,6 +1440,9 @@ resolve_specific_f0 (gfc_symbol *sym, gf
{
match m;
+ /*if (sym->attr.procedure)
+ goto found;*/
+
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
{
if (sym->attr.dummy)
@@ -7218,6 +7221,16 @@ 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). */
+ 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);
+ }
+
if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
return;
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h (revision 127848)
+++ 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 127848)
+++ 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);
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 ! forbidden by C1204
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 ! forbidden by C1207: no explicit interface
interface nn
procedure ex
procedure a, a ! forbidden: a already present
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