This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: PROCEDURE declarations
2007/8/21, Tobias Burnus <burnus@net-b.de>:
> You mean something like the following?
>
> ! integer, external :: sub
> real, external sub
> integer :: i
> i = sub()
> end
>
> This is valid as the value returned by sub (i.e. REAL) can be converted
> into INTEGER.
>
Well, that's not quite what I mean. Consider the following code, which
gives some examples of what the procedure declaration patch can handle
at this point:
integer function p1()
p1 = 5
end function
integer function p2()
p2 = 6
end function
subroutine p3()
print *,"p3"
end subroutine
subroutine p4()
print *,"p4"
end subroutine
integer function p5()
p5 =8
end function
program p
implicit none
abstract interface
subroutine abssub()
end subroutine
end interface
procedure(integer):: p1
procedure(fun):: p2
procedure(abssub):: p3
procedure(sub):: p4
procedure(real):: p5
print *, p1()
print *, p2()
call p3()
call p4()
print *,p5()
contains
integer function fun()
fun=7
end function
subroutine sub()
print *,"sub"
end subroutine
end program p
module m
procedure():: mp1
procedure(real), private:: mp2
procedure(mfun), public:: mp3
contains
real function mfun()
mfun=4.2
end function
end module
The procedure p5 illustrates what I mean: It is declared as real, but
its actual implementation returns an integer. And this integer is not
correctly converted to a real: Instead of "8" the line "print *,p5()"
gives me the output "NaN". This happens for both PROCEDURE and
EXTERNAL.
Should I make any attempt to check matching types in cases like this?
And is it even possible?
I also implemented some new checks (e.g. for C1204, C1217 and C1218)
in my patch, which you find attached. It should be able to cover a
broad spectrum of procedure declarations by now and also includes my
recent bugfixes for abstract interfaces. I will post some more
testcases for the patch soon.
Cheers,
Janus
Index: gcc/testsuite/gfortran.dg/interface_abstract_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_abstract_1.f90 (revision 127707)
+++ gcc/testsuite/gfortran.dg/interface_abstract_1.f90 (working copy)
@@ -12,4 +12,10 @@ abstract interface
subroutine real() ! { dg-error "cannot be the same as an intrinsic type" }
end subroutine real
end interface
+
+contains
+
+ subroutine sub() bind(C,name="subC")
+ end subroutine
+
end
Index: gcc/testsuite/gfortran.dg/interface_abstract_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/interface_abstract_3.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/interface_abstract_3.f90 (revision 0)
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! test for C1204 of Fortran 2003 standard:
+! module procedure not allowed in abstract interface
+module m
+ abstract interface
+ module procedure p ! { dg-error "must be in a generic module interface" }
+ end interface
+contains
+ subroutine p()
+ end subroutine
+end module m
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 127707)
+++ gcc/fortran/symbol.c (working copy)
@@ -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 127707)
+++ gcc/fortran/decl.c (working copy)
@@ -2549,8 +2549,11 @@ match_attr_spec (void)
/* Chomp the comma. */
peek_char = gfc_next_char ();
/* Try and match the bind(c). */
- if (gfc_match_bind_c (NULL) == MATCH_YES)
+ m = gfc_match_bind_c (NULL);
+ if (m == MATCH_YES)
d = DECL_IS_BIND_C;
+ else if (m == MATCH_ERROR)
+ goto cleanup;
}
}
@@ -3628,6 +3631,172 @@ 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;
+
+ 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;
+
+ if (gfc_current_state () == COMP_INTERFACE)
+ {
+ if (current_interface.type != INTERFACE_GENERIC)
+ {
+ gfc_error ("PROCEDURE at %C must be in a generic interface");
+ return MATCH_ERROR;
+ }
+ goto got_attr;
+ }
+
+ 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;
+
+ 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;
+
+got_ts:
+
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_current_locus = entry_loc;
+ return MATCH_NO;
+ }
+
+ /* Get 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;
+ }
+ /* TODO: Implement procedure pointers. */
+ if (current_attr.pointer)
+ {
+ gfc_error ("Procedure pointers used at %C are not yet implemented");
+ 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 requires interface with BIND(C) at %C");
+ return MATCH_ERROR;
+ }
+
+got_attr:
+
+ /* Get procedure symbols. */
+ for(i=1;;i++)
+ {
+ m = gfc_match_symbol (&sym, 0);
+
+ switch (m)
+ {
+ case MATCH_YES:
+
+ /* Set attributes. */
+ sym->attr = current_attr;
+ if (!current_attr.pointer)
+ sym->attr.external = 1;
+ sym->attr.procedure = 1;
+
+ /* Set binding label for BIND(C). */
+ if (sym->attr.is_bind_c)
+ if (set_binding_label (sym->binding_label, sym->name, i) != SUCCESS)
+ 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 (gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
+ return MATCH_ERROR;
+
+ 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
@@ -4183,7 +4352,8 @@ gfc_match_bind_c (gfc_symbol *sym)
strncpy (sym->binding_label, sym->name, strlen (sym->name) + 1);
}
- if (has_name_equals && current_interface.type == INTERFACE_ABSTRACT)
+ if (has_name_equals && gfc_current_state () == COMP_INTERFACE
+ && current_interface.type == INTERFACE_ABSTRACT)
{
gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
return MATCH_ERROR;
@@ -5327,7 +5497,8 @@ gfc_match_modproc (void)
if (gfc_state_stack->state != COMP_INTERFACE
|| gfc_state_stack->previous == NULL
- || current_interface.type == INTERFACE_NAMELESS)
+ || current_interface.type == INTERFACE_NAMELESS
+ || current_interface.type == INTERFACE_ABSTRACT)
{
gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
"interface");
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 127707)
+++ 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;
@@ -640,7 +640,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. */
@@ -1012,6 +1013,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;
@@ -2160,6 +2163,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 127707)
+++ gcc/fortran/resolve.c (working copy)
@@ -1431,6 +1431,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)
@@ -7221,6 +7224,16 @@ resolve_symbol (gfc_symbol *sym)
}
}
+ if (sym->attr.procedure && sym->interface)
+ {
+ /* 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);
+ sym->attr.if_source = IFSRC_DECL;
+ }
+
if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
return;
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h (revision 127707)
+++ 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 127707)
+++ 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);