+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
}
}
+ /* 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
}
+/* 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
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;
}
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);
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
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;
goto cleanup;
}
+ add_hidden_procptr_result (sym);
+
return MATCH_YES;
cleanup:
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:
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 ();
}
+/* 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. */
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);
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;
break;
}
- if (sym->attr.proc_pointer)
+ if (sym->attr.proc_pointer
+ || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
break;
/* Fall through to error */
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);
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;
}
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;
}
}
- if (sym->attr.save == SAVE_EXPLICIT && !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)
+ if (!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;
/* 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;
+ }
}
}
}
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);
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);
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);
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;
}
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);
+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
! { 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)
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
--- /dev/null
+! { 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" } }
+
--- /dev/null
+! { 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" } }
+
--- /dev/null
+!{ 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" } }
+
projects / thirdparty / gcc.git / commitdiff
