re PR fortran/51081 ([F03] Proc-pointer assignment: Rejects valid internal proc)
2012-07-30 Janus Weil <janus@gcc.gnu.org> PR fortran/51081 * gfortran.h (gfc_resolve_intrinsic): Add prototype. * expr.c (gfc_check_pointer_assign): Set INTRINSIC attribute if needed. Check for invalid intrinsics. * primary.c (gfc_match_rvalue): Check for intrinsics came too early. Set procedure flavor if appropriate. * resolve.c (resolve_intrinsic): Renamed to gfc_resolve_intrinsic. (resolve_procedure_interface,resolve_procedure_expression, resolve_function,resolve_fl_derived0,resolve_symbol): Ditto. 2012-07-30 Janus Weil <janus@gcc.gnu.org> PR fortran/51081 * gfortran.dg/proc_ptr_37.f90: New. From-SVN: r189985
This commit is contained in:
Janus Weil
parent
caf624554c
commit
2dda89a898
7 changed files with 71 additions and 12 deletions
|
|
@ -1,3 +1,15 @@
|
|||
2012-07-30 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/51081
|
||||
* gfortran.h (gfc_resolve_intrinsic): Add prototype.
|
||||
* expr.c (gfc_check_pointer_assign): Set INTRINSIC attribute if needed.
|
||||
Check for invalid intrinsics.
|
||||
* primary.c (gfc_match_rvalue): Check for intrinsics came too early.
|
||||
Set procedure flavor if appropriate.
|
||||
* resolve.c (resolve_intrinsic): Renamed to gfc_resolve_intrinsic.
|
||||
(resolve_procedure_interface,resolve_procedure_expression,
|
||||
resolve_function,resolve_fl_derived0,resolve_symbol): Ditto.
|
||||
|
||||
2012-07-26 Mikael Morin <mikael@gcc.gnu.org>
|
||||
|
||||
PR fortran/44354
|
||||
|
|
|
|||
|
|
@ -3421,6 +3421,21 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
|
|||
&rvalue->where);
|
||||
return FAILURE;
|
||||
}
|
||||
if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer)
|
||||
{
|
||||
/* Check for intrinsics. */
|
||||
gfc_symbol *sym = rvalue->symtree->n.sym;
|
||||
if (!sym->attr.intrinsic
|
||||
&& !(sym->attr.contained || sym->attr.use_assoc
|
||||
|| sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
|
||||
&& (gfc_is_intrinsic (sym, 0, sym->declared_at)
|
||||
|| gfc_is_intrinsic (sym, 1, sym->declared_at)))
|
||||
{
|
||||
sym->attr.intrinsic = 1;
|
||||
gfc_resolve_intrinsic (sym, &rvalue->where);
|
||||
attr = gfc_expr_attr (rvalue);
|
||||
}
|
||||
}
|
||||
if (attr.abstract)
|
||||
{
|
||||
gfc_error ("Abstract interface '%s' is invalid "
|
||||
|
|
@ -3444,6 +3459,13 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
|
|||
"at %L", rvalue->symtree->name, &rvalue->where)
|
||||
== FAILURE)
|
||||
return FAILURE;
|
||||
if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name,
|
||||
attr.subroutine) == 0)
|
||||
{
|
||||
gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer "
|
||||
"assignment", rvalue->symtree->name, &rvalue->where);
|
||||
return FAILURE;
|
||||
}
|
||||
}
|
||||
/* Check for F08:C730. */
|
||||
if (attr.elemental && !attr.intrinsic)
|
||||
|
|
|
|||
|
|
@ -2805,7 +2805,8 @@ int gfc_is_formal_arg (void);
|
|||
void gfc_resolve_substring_charlen (gfc_expr *);
|
||||
match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
|
||||
gfc_expr *gfc_expr_to_initialize (gfc_expr *);
|
||||
bool gfc_type_is_extensible (gfc_symbol *sym);
|
||||
bool gfc_type_is_extensible (gfc_symbol *);
|
||||
gfc_try gfc_resolve_intrinsic (gfc_symbol *, locus *);
|
||||
|
||||
|
||||
/* array.c */
|
||||
|
|
|
|||
|
|
@ -2843,13 +2843,18 @@ gfc_match_rvalue (gfc_expr **result)
|
|||
/* Parse functions returning a procptr. */
|
||||
goto function0;
|
||||
|
||||
if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
|
||||
|| gfc_is_intrinsic (sym, 1, gfc_current_locus))
|
||||
sym->attr.intrinsic = 1;
|
||||
e = gfc_get_expr ();
|
||||
e->expr_type = EXPR_VARIABLE;
|
||||
e->symtree = symtree;
|
||||
m = gfc_match_varspec (e, 0, false, true);
|
||||
if (!e->ref && sym->attr.flavor == FL_UNKNOWN
|
||||
&& sym->ts.type == BT_UNKNOWN
|
||||
&& gfc_add_flavor (&sym->attr, FL_PROCEDURE,
|
||||
sym->name, NULL) == FAILURE)
|
||||
{
|
||||
m = MATCH_ERROR;
|
||||
break;
|
||||
}
|
||||
break;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -139,7 +139,6 @@ resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
|
|||
|
||||
|
||||
static void resolve_symbol (gfc_symbol *sym);
|
||||
static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc);
|
||||
|
||||
|
||||
/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
|
||||
|
|
@ -168,7 +167,7 @@ resolve_procedure_interface (gfc_symbol *sym)
|
|||
resolve_symbol (ifc);
|
||||
|
||||
if (ifc->attr.intrinsic)
|
||||
resolve_intrinsic (ifc, &ifc->declared_at);
|
||||
gfc_resolve_intrinsic (ifc, &ifc->declared_at);
|
||||
|
||||
if (ifc->result)
|
||||
{
|
||||
|
|
@ -1499,8 +1498,8 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
|
|||
/* Resolve an intrinsic procedure: Set its function/subroutine attribute,
|
||||
its typespec and formal argument list. */
|
||||
|
||||
static gfc_try
|
||||
resolve_intrinsic (gfc_symbol *sym, locus *loc)
|
||||
gfc_try
|
||||
gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
|
||||
{
|
||||
gfc_intrinsic_sym* isym = NULL;
|
||||
const char* symstd;
|
||||
|
|
@ -1588,7 +1587,7 @@ resolve_procedure_expression (gfc_expr* expr)
|
|||
sym = expr->symtree->n.sym;
|
||||
|
||||
if (sym->attr.intrinsic)
|
||||
resolve_intrinsic (sym, &expr->where);
|
||||
gfc_resolve_intrinsic (sym, &expr->where);
|
||||
|
||||
if (sym->attr.flavor != FL_PROCEDURE
|
||||
|| (sym->attr.function && sym->result == sym))
|
||||
|
|
@ -3064,7 +3063,7 @@ resolve_function (gfc_expr *expr)
|
|||
return SUCCESS;
|
||||
|
||||
if (sym && sym->attr.intrinsic
|
||||
&& resolve_intrinsic (sym, &expr->where) == FAILURE)
|
||||
&& gfc_resolve_intrinsic (sym, &expr->where) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
|
||||
|
|
@ -11884,7 +11883,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
|
|||
resolve_symbol (ifc);
|
||||
|
||||
if (ifc->attr.intrinsic)
|
||||
resolve_intrinsic (ifc, &ifc->declared_at);
|
||||
gfc_resolve_intrinsic (ifc, &ifc->declared_at);
|
||||
|
||||
if (ifc->result)
|
||||
{
|
||||
|
|
@ -12519,7 +12518,7 @@ resolve_symbol (gfc_symbol *sym)
|
|||
representation. This needs to be done before assigning a default
|
||||
type to avoid spurious warnings. */
|
||||
if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
|
||||
&& resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
|
||||
&& gfc_resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
|
||||
return;
|
||||
|
||||
/* Resolve associate names. */
|
||||
|
|
|
|||
|
|
@ -1,3 +1,8 @@
|
|||
2012-07-30 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/51081
|
||||
* gfortran.dg/proc_ptr_37.f90: New.
|
||||
|
||||
2012-07-30 Ulrich Weigand <ulrich.weigand@linaro.org>
|
||||
|
||||
* lib/target-supports.exp
|
||||
|
|
|
|||
15
gcc/testsuite/gfortran.dg/proc_ptr_37.f90
Normal file
15
gcc/testsuite/gfortran.dg/proc_ptr_37.f90
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
! { dg-do compile }
|
||||
!
|
||||
! PR 51081: [F03] Proc-pointer assignment: Rejects valid internal proc
|
||||
!
|
||||
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
|
||||
|
||||
procedure(), pointer :: p1
|
||||
procedure(real), pointer :: p2
|
||||
p1 => int2
|
||||
p2 => scale ! { dg-error "is invalid in procedure pointer assignment" }
|
||||
contains
|
||||
subroutine int2()
|
||||
print *,"..."
|
||||
end subroutine
|
||||
end
|
||||
Loading…
Add table
Reference in a new issue