OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/36704 (Procedure pointer as function result)

Browse Source 
2009-04-09  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36704
	* decl.c (add_hidden_procptr_result): New function for handling
	procedure pointer return values by adding a hidden result variable.
	(variable_decl,match_procedure_decl,gfc_match_function_decl,
	gfc_match_subroutine,gfc_match_end,attr_decl1): Handle procedure pointer
	return values.
	* parse.c (parse_interface): Add EXTERNAL attribute only after
	FUNCTION/SUBROUTINE declaration is complete.
	* primary.c (replace_hidden_procptr_result): New function for replacing
	function symbol by hidden result variable.
	(gfc_match_rvalue,match_variable): Replace symbol by hidden result
	variable.
	* resolve.c (resolve_contained_fntype,resolve_function,resolve_variable,
	resolve_symbol): Allow for procedure pointer function results.
	(resolve_fl_procedure): Conflict detection moved here from
	'check_conflict'.
	* symbol.c (gfc_check_function_type): Allow for procedure pointer
	function results.
	(check_conflict): Move some conflict detection to resolution stage.
	* trans-types.c (gfc_sym_type,gfc_get_function_type): Handle hidden
	result variables.


2009-04-09  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36704
	* gfortran.dg/external_procedures_1.f90: Modified.
	* gfortran.dg/proc_ptr_result_1.f90: New.
	* gfortran.dg/proc_ptr_result_2.f90: New.
	* gfortran.dg/proc_ptr_result_3.f90: New.

From-SVN: r145815
This commit is contained in:
Janus Weil 2009-04-09 11:39:09 +02:00
parent b61ee1aa7b
commit 3070bab4c9
12 changed files with 531 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
gcc/fortran/ChangeLog
View File

@ -1,3 +1,27 @@
2009-04-09 Janus Weil <janus@gcc.gnu.org>
PR fortran/36704
* decl.c (add_hidden_procptr_result): New function for handling
procedure pointer return values by adding a hidden result variable.
(variable_decl,match_procedure_decl,gfc_match_function_decl,
gfc_match_subroutine,gfc_match_end,attr_decl1): Handle procedure pointer
return values.
* parse.c (parse_interface): Add EXTERNAL attribute only after
FUNCTION/SUBROUTINE declaration is complete.
* primary.c (replace_hidden_procptr_result): New function for replacing
function symbol by hidden result variable.
(gfc_match_rvalue,match_variable): Replace symbol by hidden result
variable.
* resolve.c (resolve_contained_fntype,resolve_function,resolve_variable,
resolve_symbol): Allow for procedure pointer function results.
(resolve_fl_procedure): Conflict detection moved here from
'check_conflict'.
* symbol.c (gfc_check_function_type): Allow for procedure pointer
function results.
(check_conflict): Move some conflict detection to resolution stage.
* trans-types.c (gfc_sym_type,gfc_get_function_type): Handle hidden
result variables.
2009-04-08 Jakub Jelinek <jakub@redhat.com>
* trans-types.c (gfc_init_types): Ensure gfc_integer_types doesn't

96
gcc/fortran/decl.c
View File

@ -1667,6 +1667,17 @@ variable_decl (int elem)
}
}
/* Procedure pointer as function result. */
if (gfc_current_state () == COMP_FUNCTION
&& strcmp ("ppr@", gfc_current_block ()->name) == 0
&& strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
strcpy (name, "ppr@");
if (gfc_current_state () == COMP_FUNCTION
&& strcmp (name, gfc_current_block ()->name) == 0
&& gfc_current_block ()->result
&& strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
strcpy (name, "ppr@");
/* OK, we've successfully matched the declaration. Now put the
symbol in the current namespace, because it might be used in the
@ -4069,6 +4080,66 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
}
/* Procedure pointer return value without RESULT statement:
Add "hidden" result variable named "ppr@". */
static gfc_try
add_hidden_procptr_result (gfc_symbol *sym)
{
bool case1,case2;
if (gfc_notification_std (GFC_STD_F2003) == ERROR)
return FAILURE;
/* First usage case: PROCEDURE and EXTERNAL statements. */
case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
&& strcmp (gfc_current_block ()->name, sym->name) == 0
&& sym->attr.external;
/* Second usage case: INTERFACE statements. */
case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
&& gfc_state_stack->previous->state == COMP_FUNCTION
&& strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
if (case1 || case2)
{
gfc_symtree *stree;
if (case1)
gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree);
else if (case2)
gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree);
sym->result = stree->n.sym;
sym->result->attr.proc_pointer = sym->attr.proc_pointer;
sym->result->attr.pointer = sym->attr.pointer;
sym->result->attr.external = sym->attr.external;
sym->result->attr.referenced = sym->attr.referenced;
sym->attr.proc_pointer = 0;
sym->attr.pointer = 0;
sym->attr.external = 0;
if (sym->result->attr.external && sym->result->attr.pointer)
{
sym->result->attr.pointer = 0;
sym->result->attr.proc_pointer = 1;
}
return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
}
/* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
&& sym->result && sym->result != sym && sym->result->attr.external
&& sym == gfc_current_ns->proc_name
&& sym == sym->result->ns->proc_name
&& strcmp ("ppr@", sym->result->name) == 0)
{
sym->result->attr.proc_pointer = 1;
sym->attr.pointer = 0;
return SUCCESS;
}
else
return FAILURE;
}
/* Match a PROCEDURE declaration (R1211). */
static match
@ -4201,6 +4272,10 @@ got_ts:
if (gfc_add_external (&sym->attr, NULL) == FAILURE)
return MATCH_ERROR;
if (add_hidden_procptr_result (sym) == SUCCESS)
sym = sym->result;
if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
@ -4415,6 +4490,10 @@ gfc_match_function_decl (void)
}
if (get_proc_name (name, &sym, false))
return MATCH_ERROR;
if (add_hidden_procptr_result (sym) == SUCCESS)
sym = sym->result;
gfc_new_block = sym;
m = gfc_match_formal_arglist (sym, 0, 0);
@ -4812,6 +4891,10 @@ gfc_match_subroutine (void)
if (get_proc_name (name, &sym, false))
return MATCH_ERROR;
if (add_hidden_procptr_result (sym) == SUCCESS)
sym = sym->result;
gfc_new_block = sym;
/* Check what next non-whitespace character is so we can tell if there
@ -5259,12 +5342,21 @@ gfc_match_end (gfc_statement *st)
if (block_name == NULL)
goto syntax;
if (strcmp (name, block_name) != 0)
if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
{
gfc_error ("Expected label '%s' for %s statement at %C", block_name,
gfc_ascii_statement (*st));
goto cleanup;
}
/* Procedure pointer as function result. */
else if (strcmp (block_name, "ppr@") == 0
&& strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
{
gfc_error ("Expected label '%s' for %s statement at %C",
gfc_current_block ()->ns->proc_name->name,
gfc_ascii_statement (*st));
goto cleanup;
}
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
@ -5375,6 +5467,8 @@ attr_decl1 (void)
goto cleanup;
}
add_hidden_procptr_result (sym);
return MATCH_YES;
cleanup:

12
gcc/fortran/parse.c
View File

@ -2113,14 +2113,6 @@ loop:
gfc_free_namespace (gfc_current_ns);
goto loop;
}
if (current_interface.type != INTERFACE_ABSTRACT &&
!gfc_new_block->attr.dummy &&
gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE)
{
reject_statement ();
gfc_free_namespace (gfc_current_ns);
goto loop;
}
break;
case ST_PROCEDURE:
@ -2213,6 +2205,10 @@ decl:
goto decl;
}
/* Add EXTERNAL attribute to function or subroutine. */
if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
gfc_add_external (&prog_unit->attr, &gfc_current_locus);
current_interface = save;
gfc_add_interface (prog_unit);
pop_state ();

31
gcc/fortran/primary.c
View File

@ -2358,6 +2358,30 @@ check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
}
/* Procedure pointer as function result: Replace the function symbol by the
auto-generated hidden result variable named "ppr@". */
static gfc_try
replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
{
/* Check for procedure pointer result variable. */
if ((*sym)->attr.function && !(*sym)->attr.external
&& (*sym)->result && (*sym)->result != *sym
&& (*sym)->result->attr.proc_pointer
&& (*sym) == gfc_current_ns->proc_name
&& (*sym) == (*sym)->result->ns->proc_name
&& strcmp ("ppr@", (*sym)->result->name) == 0)
{
/* Automatic replacement with "hidden" result variable. */
(*sym)->result->attr.referenced = (*sym)->attr.referenced;
*sym = (*sym)->result;
*st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
return SUCCESS;
}
return FAILURE;
}
/* Matches a variable name followed by anything that might follow it--
array reference, argument list of a function, etc. */
@ -2394,6 +2418,8 @@ gfc_match_rvalue (gfc_expr **result)
e = NULL;
where = gfc_current_locus;
replace_hidden_procptr_result (&sym, &symtree);
/* If this is an implicit do loop index and implicitly typed,
it should not be host associated. */
m = check_for_implicit_index (&symtree, &sym);
@ -2583,6 +2609,8 @@ gfc_match_rvalue (gfc_expr **result)
gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
sym = symtree->n.sym;
replace_hidden_procptr_result (&sym, &symtree);
e = gfc_get_expr ();
e->symtree = symtree;
e->expr_type = EXPR_FUNCTION;
@ -2912,7 +2940,8 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
break;
}
if (sym->attr.proc_pointer)
if (sym->attr.proc_pointer
|| replace_hidden_procptr_result (&sym, &st) == SUCCESS)
break;
/* Fall through to error */

69
gcc/fortran/resolve.c
View File

@ -344,7 +344,7 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
if (sym->result == sym)
gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
sym->name, &sym->declared_at);
else
else if (!sym->result->attr.proc_pointer)
gfc_error ("Result '%s' of contained function '%s' at %L has "
"no IMPLICIT type", sym->result->name, sym->name,
&sym->result->declared_at);
@ -2530,7 +2530,8 @@ resolve_function (gfc_expr *expr)
if (expr->ts.type == BT_UNKNOWN)
{
if (expr->symtree->n.sym->result
&& expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
&& expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
&& !expr->symtree->n.sym->result->attr.proc_pointer)
expr->ts = expr->symtree->n.sym->result->ts;
}
@ -4196,7 +4197,11 @@ resolve_variable (gfc_expr *e)
return FAILURE;
sym = e->symtree->n.sym;
if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
if (sym->attr.flavor == FL_PROCEDURE
&& (!sym->attr.function
|| (sym->attr.function && sym->result
&& sym->result->attr.proc_pointer
&& !sym->result->attr.function)))
{
e->ts.type = BT_PROCEDURE;
goto resolve_procedure;
@ -8034,18 +8039,41 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
}
}
if (sym->attr.save == SAVE_EXPLICIT && !sym->attr.proc_pointer)
if (!sym->attr.proc_pointer)
{
gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
"in '%s' at %L", sym->name, &sym->declared_at);
return FAILURE;
}
if (sym->attr.intent && !sym->attr.proc_pointer)
{
gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
"in '%s' at %L", sym->name, &sym->declared_at);
return FAILURE;
if (sym->attr.save == SAVE_EXPLICIT)
{
gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
"in '%s' at %L", sym->name, &sym->declared_at);
return FAILURE;
}
if (sym->attr.intent)
{
gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
"in '%s' at %L", sym->name, &sym->declared_at);
return FAILURE;
}
if (sym->attr.subroutine && sym->attr.result)
{
gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
"in '%s' at %L", sym->name, &sym->declared_at);
return FAILURE;
}
if (sym->attr.external && sym->attr.function
&& ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure)
|| sym->attr.contained))
{
gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
"in '%s' at %L", sym->name, &sym->declared_at);
return FAILURE;
}
if (strcmp ("ppr@", sym->name) == 0)
{
gfc_error ("Procedure pointer result '%s' at %L "
"is missing the pointer attribute",
sym->ns->proc_name->name, &sym->declared_at);
return FAILURE;
}
}
return SUCCESS;
@ -9310,11 +9338,14 @@ resolve_symbol (gfc_symbol *sym)
/* Result may be in another namespace. */
resolve_symbol (sym->result);
sym->ts = sym->result->ts;
sym->as = gfc_copy_array_spec (sym->result->as);
sym->attr.dimension = sym->result->attr.dimension;
sym->attr.pointer = sym->result->attr.pointer;
sym->attr.allocatable = sym->result->attr.allocatable;
if (!sym->result->attr.proc_pointer)
{
sym->ts = sym->result->ts;
sym->as = gfc_copy_array_spec (sym->result->as);
sym->attr.dimension = sym->result->attr.dimension;
sym->attr.pointer = sym->result->attr.pointer;
sym->attr.allocatable = sym->result->attr.allocatable;
}
}
}
}

12
gcc/fortran/symbol.c
View File

@ -320,7 +320,7 @@ gfc_check_function_type (gfc_namespace *ns)
proc->attr.allocatable = proc->result->attr.allocatable;
}
}
else
else if (!proc->result->attr.proc_pointer)
{
gfc_error ("Function result '%s' at %L has no IMPLICIT type",
proc->result->name, &proc->result->declared_at);
@ -453,10 +453,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
conf (entry, intrinsic);
if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
{
conf (external, subroutine);
conf (external, function);
}
conf (external, subroutine);
conf (allocatable, pointer);
conf_std (allocatable, dummy, GFC_STD_F2003);
@ -626,14 +623,13 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
break;
case FL_PROCEDURE:
/* Conflicts with INTENT will be checked at resolution stage,
see "resolve_fl_procedure". */
/* Conflicts with INTENT, SAVE and RESULT will be checked
at resolution stage, see "resolve_fl_procedure". */
if (attr->subroutine)
{
conf2 (target);
conf2 (allocatable);
conf2 (result);
conf2 (in_namelist);
conf2 (dimension);
conf2 (function);

17
gcc/fortran/trans-types.c
View File

@ -1616,8 +1616,8 @@ gfc_sym_type (gfc_symbol * sym)
tree type;
int byref;
/* Procedure Pointers inside COMMON blocks or as function result. */
if (sym->attr.proc_pointer && (sym->attr.in_common || sym->attr.result))
/* Procedure Pointers inside COMMON blocks. */
if (sym->attr.proc_pointer && sym->attr.in_common)
{
/* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
sym->attr.proc_pointer = 0;
@ -2156,7 +2156,18 @@ gfc_get_function_type (gfc_symbol * sym)
}
else if (sym->result && sym->result->attr.proc_pointer)
/* Procedure pointer return values. */
type = gfc_sym_type (sym->result);
{
if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
{
/* Unset proc_pointer as gfc_get_function_type
is called recursively. */
sym->result->attr.proc_pointer = 0;
type = build_pointer_type (gfc_get_function_type (sym->result));
sym->result->attr.proc_pointer = 1;
}
else
type = gfc_sym_type (sym->result);
}
else
type = gfc_sym_type (sym);

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,11 @@
2009-04-09 Janus Weil <janus@gcc.gnu.org>
PR fortran/36704
* gfortran.dg/external_procedures_1.f90: Modified.
* gfortran.dg/proc_ptr_result_1.f90: New.
* gfortran.dg/proc_ptr_result_2.f90: New.
* gfortran.dg/proc_ptr_result_3.f90: New.
2009-04-09 Richard Guenther <rguenther@suse.de>
* gcc.dg/vect/vect-54.c: Make constant input data file-scope

19
gcc/testsuite/gfortran.dg/external_procedures_1.f90
View File

@ -1,14 +1,17 @@
! { dg-do compile }
! { dg-options "-std=f95" }
!
! This tests the patch for PR25024.
! PR25024 - The external attribute for subroutine a would cause an ICE.
subroutine A ()
EXTERNAL A ! { dg-error "EXTERNAL attribute conflicts with SUBROUTINE" }
END
function ext (y)
function ext (y) ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" }
real ext, y
external ext ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" }
ext = y * y
external ext
!ext = y * y
end function ext
function ext1 (y)
@ -24,18 +27,18 @@ program main
interface
function ext1 (y)
real ext1, y
external ext1 ! { dg-error "Duplicate EXTERNAL attribute" }
end function ext1
external ext1
end function ext1 ! { dg-error "Duplicate EXTERNAL attribute" }
end interface
inval = 1.0
print *, ext(inval)
print *, ext1(inval)
print *, inv(inval)
contains
function inv (y)
function inv (y) ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" }
real inv, y
external inv ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" }
inv = y * y * y
external inv
!inv = y * y * y
end function inv
end program main

173
gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 Normal file
View File

@ -0,0 +1,173 @@
! { dg-do run }
!
! PR 36704: Procedure pointer as function result
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
module mo
contains
function j()
procedure(),pointer :: j
intrinsic iabs
j => iabs
end function
subroutine sub(y)
integer,intent(inout) :: y
y = y**2
end subroutine
end module
program proc_ptr_14
use mo
implicit none
intrinsic :: iabs
integer :: x
procedure(integer),pointer :: p,p2
procedure(sub),pointer :: ps
p => a()
if (p(-1)/=1) call abort()
p => b()
if (p(-2)/=2) call abort()
p => c()
if (p(-3)/=3) call abort()
p => d()
if (p(-4)/=4) call abort()
p => dd()
if (p(-4)/=4) call abort()
p => e(iabs)
if (p(-5)/=5) call abort()
p => ee()
if (p(-5)/=5) call abort()
p => f()
if (p(-6)/=6) call abort()
p => g()
if (p(-7)/=7) call abort()
ps => h(sub)
x = 2
call ps(x)
if (x/=4) call abort()
p => i()
if (p(-8)/=8) call abort()
p => j()
if (p(-9)/=9) call abort()
p => k(p2)
if (p(-10)/=p2(-10)) call abort()
p => l()
if (p(-11)/=11) call abort()
contains
function a()
procedure(integer),pointer :: a
a => iabs
end function
function b()
procedure(integer) :: b
pointer :: b
b => iabs
end function
function c()
pointer :: c
procedure(integer) :: c
c => iabs
end function
function d()
pointer :: d
external d
d => iabs
end function
function dd()
pointer :: dd
external :: dd
integer :: dd
dd => iabs
end function
function e(arg)
external :: e,arg
pointer :: e
e => arg
end function
function ee()
integer :: ee
external :: ee
pointer :: ee
ee => iabs
end function
function f()
pointer :: f
interface
integer function f(x)
integer :: x
end function
end interface
f => iabs
end function
function g()
interface
integer function g(x)
integer :: x
end function g
end interface
pointer :: g
g => iabs
end function
function h(arg)
interface
subroutine arg(b)
integer :: b
end subroutine arg
end interface
pointer :: h
interface
subroutine h(a)
integer :: a
end subroutine h
end interface
h => arg
end function
function i()
pointer :: i
interface
function i(x)
integer :: i,x
end function i
end interface
i => iabs
end function
function k(arg)
procedure(),pointer :: k,arg
k => iabs
arg => k
end function
function l()
procedure(iabs),pointer :: l
integer :: i
l => iabs
if (l(-11)/=11) call abort()
end function
end
! { dg-final { cleanup-modules "mo" } }

62
gcc/testsuite/gfortran.dg/proc_ptr_result_2.f90 Normal file
View File

@ -0,0 +1,62 @@
! { dg-do compile }
!
! PR 36704: Procedure pointer as function result
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
module proc_ptr_15
interface
function e(x)
real :: x
procedure(), pointer :: e
end function e
end interface
interface
function f(x)
real :: x
external :: f
pointer :: f
end function
end interface
interface
function g(x)
real :: x
pointer :: g
external :: g
end function
end interface
contains
subroutine point_fun()
call set_fun(aux)
end subroutine
subroutine set_fun(y)
external :: y
end subroutine
function aux()
external aux
pointer aux
intrinsic sin
aux => sin
end function
function foo(x)
real :: x
interface
subroutine foo(i) ! { dg-error "attribute conflicts with" }
integer :: i
end subroutine
end interface
!pointer :: foo
end function
end
! { dg-final { cleanup-modules "proc_ptr_15" } }

56
gcc/testsuite/gfortran.dg/proc_ptr_result_3.f90 Normal file
View File

@ -0,0 +1,56 @@
!{ dg-do run }
!
! PR 36704: Procedure pointer as function result
!
! Original test case from James Van Buskirk.
!
! Adapted by Janus Weil <janus@gcc.gnu.org>
module store_subroutine
implicit none
abstract interface
subroutine sub(i)
integer, intent(inout) :: i
end subroutine sub
end interface
procedure(sub), pointer, private :: psub => NULL()
contains
subroutine set_sub(x)
procedure(sub) x
psub => x
end subroutine set_sub
function get_sub()
procedure(sub), pointer :: get_sub
get_sub => psub
end function get_sub
end module store_subroutine
program test
use store_subroutine
implicit none
procedure(sub), pointer :: qsub
integer :: k = 1
call my_sub(k)
if (k/=3) call abort
qsub => get_sub()
call qsub(k)
if (k/=9) call abort
end program test
recursive subroutine my_sub(j)
use store_subroutine
implicit none
integer, intent(inout) :: j
j = j*3
call set_sub(my_sub)
end subroutine my_sub
! { dg-final { cleanup-modules "store_subroutine" } }