procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

decl.c (match_procedure_decl,match_procedure_in_interface, [...]): Handle PROCEDURE statements.

Browse source 
2007-09-04  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-04  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.


Co-Authored-By: Paul Thomas <pault@gcc.gnu.org>
Co-Authored-By: Tobias Burnus <burnus@net-b.de>

From-SVN: r128081
This commit is contained in:
Janus Weil 2007-09-04 13:50:35 +00:00 • committed by Tobias Burnus
parent 8070c91a53
commit 6977374226
13 changed files with 691 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
gcc/fortran/ChangeLog
View file

@ -1,3 +1,20 @@
2007-09-04 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 Daniel Jacobowitz <dan@codesourcery.com>
* Make-lang.in (gfortranspec.o): Remove SHLIB_MULTILIB.

242
gcc/fortran/decl.c
View file

@ -3759,6 +3759,248 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
}
/* 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 ("Fortran 2003: Support for intrinsic procedure '%s' "
"in PROCEDURE statement at %C not yet implemented "
"in gfortran", 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;
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

10
gcc/fortran/gfortran.h
View file

@ -222,7 +222,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;
@ -589,7 +589,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. */
@ -961,6 +962,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;
@ -2039,6 +2042,7 @@ try gfc_add_recursive (symbol_attribute *, locus *);
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);
@ -2110,6 +2114,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;

3
gcc/fortran/interface.c
View file

@ -986,7 +986,8 @@ check_interface0 (gfc_interface *p, const char *interface_name)
/* 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",

1
gcc/fortran/match.h
View file

@ -133,6 +133,7 @@ match gfc_match_old_kind_spec (gfc_typespec *);
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);

9
gcc/fortran/parse.c
View file

@ -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);

19
gcc/fortran/resolve.c
View file

@ -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;

98
gcc/fortran/symbol.c
View file

@ -352,7 +352,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
*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, const char *name, locus *where)
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, const char *name, locus *where)
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, const char *name, locus *where)
}
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, ifsrc source,
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

8
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,11 @@
2007-09-04 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.
2007-09-04 Jan Hubicka <jh@suse.cz>
* gcc.dg/vect/vect-reduc-dot-s16b.c: Mark functions noinline.

77
gcc/testsuite/gfortran.dg/proc_decl_1.f90 Normal file
View file

@ -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 "PROCEDURE statement at .1. not yet implemented" }
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

128
gcc/testsuite/gfortran.dg/proc_decl_2.f90 Normal file
View file

@ -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

75
gcc/testsuite/gfortran.dg/proc_decl_3.f90 Normal file
View file

@ -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

10
gcc/testsuite/gfortran.dg/proc_decl_4.f90 Normal file
View file

@ -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