mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 19:51:34 +08:00
Code Issues Packages Projects Releases Wiki Activity

gfortran.h (gfc_get_proc_ptr_comp): New prototype.

Browse Source 
fortran/
	* gfortran.h (gfc_get_proc_ptr_comp): New prototype.
	(gfc_is_proc_ptr_comp): Update prototype.
	* expr.c (gfc_get_proc_ptr_comp): New function based on the old
	gfc_is_proc_ptr_comp.
	(gfc_is_proc_ptr_comp): Call gfc_get_proc_ptr_comp.
	(gfc_specification_expr, gfc_check_pointer_assign): Use
	gfc_get_proc_ptr_comp.
	* trans-array.c (gfc_walk_function_expr): Likewise.
	* resolve.c (resolve_structure_cons, update_ppc_arglist,
	resolve_ppc_call, resolve_expr_ppc): Likewise.
	(resolve_function): Update call to gfc_is_proc_ptr_comp.
	* dump-parse-tree.c (show_expr): Likewise.
	* interface.c (compare_actual_formal): Likewise.
	* match.c (gfc_match_pointer_assignment): Likewise.
	* primary.c (gfc_match_varspec): Likewise.
	* trans-io.c (gfc_trans_transfer): Likewise.
	* trans-expr.c (gfc_conv_variable, conv_function_val,
	conv_isocbinding_procedure, gfc_conv_procedure_call,
	gfc_trans_pointer_assignment): Likewise.
	(gfc_conv_procedure_call, gfc_trans_array_func_assign):
	Use gfc_get_proc_ptr_comp.

From-SVN: r190391
This commit is contained in:
Mikael Morin 2012-08-14 16:28:29 +00:00
parent cc360b36df
commit 2a573572eb
11 changed files with 80 additions and 49 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 @@
2012-08-14 Mikael Morin <mikael@gcc.gnu.org>
* gfortran.h (gfc_get_proc_ptr_comp): New prototype.
(gfc_is_proc_ptr_comp): Update prototype.
* expr.c (gfc_get_proc_ptr_comp): New function based on the old
gfc_is_proc_ptr_comp.
(gfc_is_proc_ptr_comp): Call gfc_get_proc_ptr_comp.
(gfc_specification_expr, gfc_check_pointer_assign): Use
gfc_get_proc_ptr_comp.
* trans-array.c (gfc_walk_function_expr): Likewise.
* resolve.c (resolve_structure_cons, update_ppc_arglist,
resolve_ppc_call, resolve_expr_ppc): Likewise.
(resolve_function): Update call to gfc_is_proc_ptr_comp.
* dump-parse-tree.c (show_expr): Likewise.
* interface.c (compare_actual_formal): Likewise.
* match.c (gfc_match_pointer_assignment): Likewise.
* primary.c (gfc_match_varspec): Likewise.
* trans-io.c (gfc_trans_transfer): Likewise.
* trans-expr.c (gfc_conv_variable, conv_function_val,
conv_isocbinding_procedure, gfc_conv_procedure_call,
gfc_trans_pointer_assignment): Likewise.
(gfc_conv_procedure_call, gfc_trans_array_func_assign):
Use gfc_get_proc_ptr_comp.
2012-08-14 Tobias Burnus <burnus@net-b.de>
PR fortran/40881

4
gcc/fortran/dump-parse-tree.c
View File

@ -569,7 +569,7 @@ show_expr (gfc_expr *p)
if (p->value.function.name == NULL)
{
fprintf (dumpfile, "%s", p->symtree->n.sym->name);
if (gfc_is_proc_ptr_comp (p, NULL))
if (gfc_is_proc_ptr_comp (p))
show_ref (p->ref);
fputc ('[', dumpfile);
show_actual_arglist (p->value.function.actual);
@ -578,7 +578,7 @@ show_expr (gfc_expr *p)
else
{
fprintf (dumpfile, "%s", p->value.function.name);
if (gfc_is_proc_ptr_comp (p, NULL))
if (gfc_is_proc_ptr_comp (p))
show_ref (p->ref);
fputc ('[', dumpfile);
fputc ('[', dumpfile);

48
gcc/fortran/expr.c
View File

@ -2962,12 +2962,12 @@ gfc_specification_expr (gfc_expr *e)
return FAILURE;
}
comp = gfc_get_proc_ptr_comp (e);
if (e->expr_type == EXPR_FUNCTION
&& !e->value.function.isym
&& !e->value.function.esym
&& !gfc_pure (e->symtree->n.sym)
&& (!gfc_is_proc_ptr_comp (e, &comp)
|| !comp->attr.pure))
&& !e->value.function.isym
&& !e->value.function.esym
&& !gfc_pure (e->symtree->n.sym)
&& (!comp || !comp->attr.pure))
{
gfc_error ("Function '%s' at %L must be PURE",
e->symtree->n.sym->name, &e->where);
@ -3495,12 +3495,14 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
}
}
if (gfc_is_proc_ptr_comp (lvalue, &comp))
comp = gfc_get_proc_ptr_comp (lvalue);
if (comp)
s1 = comp->ts.interface;
else
s1 = lvalue->symtree->n.sym;
if (gfc_is_proc_ptr_comp (rvalue, &comp))
comp = gfc_get_proc_ptr_comp (rvalue);
if (comp)
{
s2 = comp->ts.interface;
name = comp->name;
@ -4075,31 +4077,35 @@ gfc_expr_set_symbols_referenced (gfc_expr *expr)
}
/* Determine if an expression is a procedure pointer component. If yes, the
argument 'comp' will point to the component (provided that 'comp' was
provided). */
/* Determine if an expression is a procedure pointer component and return
the component in that case. Otherwise return NULL. */
bool
gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
gfc_component *
gfc_get_proc_ptr_comp (gfc_expr *expr)
{
gfc_ref *ref;
bool ppc = false;
if (!expr || !expr->ref)
return false;
return NULL;
ref = expr->ref;
while (ref->next)
ref = ref->next;
if (ref->type == REF_COMPONENT)
{
ppc = ref->u.c.component->attr.proc_pointer;
if (ppc && comp)
*comp = ref->u.c.component;
}
if (ref->type == REF_COMPONENT
&& ref->u.c.component->attr.proc_pointer)
return ref->u.c.component;
return ppc;
return NULL;
}
/* Determine if an expression is a procedure pointer component. */
bool
gfc_is_proc_ptr_comp (gfc_expr *expr)
{
return (gfc_get_proc_ptr_comp (expr) != NULL);
}

3
gcc/fortran/gfortran.h
View File

@ -2766,7 +2766,8 @@ gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
void gfc_expr_replace_symbols (gfc_expr *, gfc_symbol *);
void gfc_expr_replace_comp (gfc_expr *, gfc_component *);
bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **);
gfc_component * gfc_get_proc_ptr_comp (gfc_expr *);
bool gfc_is_proc_ptr_comp (gfc_expr *);
bool gfc_ref_this_image (gfc_ref *ref);
bool gfc_is_coindexed (gfc_expr *);

4
gcc/fortran/interface.c
View File

@ -2558,7 +2558,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
&& a->expr->symtree->n.sym->attr.proc_pointer)
|| (a->expr->expr_type == EXPR_FUNCTION
&& a->expr->symtree->n.sym->result->attr.proc_pointer)
|| gfc_is_proc_ptr_comp (a->expr, NULL)))
|| gfc_is_proc_ptr_comp (a->expr)))
{
if (where)
gfc_error ("Expected a procedure pointer for argument '%s' at %L",
@ -2568,7 +2568,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
/* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
provided for a procedure formal argument. */
if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL)
if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr)
&& a->expr->expr_type == EXPR_VARIABLE
&& f->sym->attr.flavor == FL_PROCEDURE)
{

2
gcc/fortran/match.c
View File

@ -1344,7 +1344,7 @@ gfc_match_pointer_assignment (void)
}
if (lvalue->symtree->n.sym->attr.proc_pointer
|| gfc_is_proc_ptr_comp (lvalue, NULL))
|| gfc_is_proc_ptr_comp (lvalue))
gfc_matching_procptr_assignment = 1;
else
gfc_matching_ptr_assignment = 1;

2
gcc/fortran/primary.c
View File

@ -1862,7 +1862,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
if ((equiv_flag && gfc_peek_ascii_char () == '(')
|| gfc_peek_ascii_char () == '[' || sym->attr.codimension
|| (sym->attr.dimension && sym->ts.type != BT_CLASS
&& !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary, NULL)
&& !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
&& !(gfc_matching_procptr_assignment
&& sym->attr.flavor == FL_PROCEDURE))
|| (sym->ts.type == BT_CLASS && sym->attr.class_ok

20
gcc/fortran/resolve.c
View File

@ -1195,7 +1195,8 @@ resolve_structure_cons (gfc_expr *expr, int init)
const char *name;
char err[200];
if (gfc_is_proc_ptr_comp (cons->expr, &c2))
c2 = gfc_get_proc_ptr_comp (cons->expr);
if (c2)
{
s2 = c2->ts.interface;
name = c2->name;
@ -3093,9 +3094,9 @@ resolve_function (gfc_expr *expr)
sym = expr->symtree->n.sym;
/* If this is a procedure pointer component, it has already been resolved. */
if (gfc_is_proc_ptr_comp (expr, NULL))
if (gfc_is_proc_ptr_comp (expr))
return SUCCESS;
if (sym && sym->attr.intrinsic
&& gfc_resolve_intrinsic (sym, &expr->where) == FAILURE)
return FAILURE;
@ -5740,7 +5741,8 @@ update_ppc_arglist (gfc_expr* e)
gfc_component *ppc;
gfc_typebound_proc* tb;
if (!gfc_is_proc_ptr_comp (e, &ppc))
ppc = gfc_get_proc_ptr_comp (e);
if (!ppc)
return FAILURE;
tb = ppc->tb;
@ -6363,10 +6365,9 @@ static gfc_try
resolve_ppc_call (gfc_code* c)
{
gfc_component *comp;
bool b;
b = gfc_is_proc_ptr_comp (c->expr1, &comp);
gcc_assert (b);
comp = gfc_get_proc_ptr_comp (c->expr1);
gcc_assert (comp != NULL);
c->resolved_sym = c->expr1->symtree->n.sym;
c->expr1->expr_type = EXPR_VARIABLE;
@ -6398,10 +6399,9 @@ static gfc_try
resolve_expr_ppc (gfc_expr* e)
{
gfc_component *comp;
bool b;
b = gfc_is_proc_ptr_comp (e, &comp);
gcc_assert (b);
comp = gfc_get_proc_ptr_comp (e);
gcc_assert (comp != NULL);
/* Convert to EXPR_FUNCTION. */
e->expr_type = EXPR_FUNCTION;

2
gcc/fortran/trans-array.c
View File

@ -8666,7 +8666,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
sym = expr->symtree->n.sym;
/* A function that returns arrays. */
gfc_is_proc_ptr_comp (expr, &comp);
comp = gfc_get_proc_ptr_comp (expr);
if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
|| (comp && comp->attr.dimension))
return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);

18
gcc/fortran/trans-expr.c
View File

@ -1512,9 +1512,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
separately. */
if (se->want_pointer)
{
if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
gfc_conv_string_parameter (se);
else
else
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
}
}
@ -2438,7 +2438,7 @@ conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
{
tree tmp;
if (gfc_is_proc_ptr_comp (expr, NULL))
if (gfc_is_proc_ptr_comp (expr))
tmp = get_proc_ptr_comp (expr);
else if (sym->attr.dummy)
{
@ -3447,7 +3447,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
if (arg->next->expr->rank == 0)
{
if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
|| gfc_is_proc_ptr_comp (arg->next->expr, NULL))
|| gfc_is_proc_ptr_comp (arg->next->expr))
fptrse.want_pointer = 1;
gfc_conv_expr (&fptrse, arg->next->expr);
@ -3649,7 +3649,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& conv_isocbinding_procedure (se, sym, args))
return 0;
gfc_is_proc_ptr_comp (expr, &comp);
comp = gfc_get_proc_ptr_comp (expr);
if (se->ss != NULL)
{
@ -3958,7 +3958,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& e->symtree->n.sym->attr.dummy))
|| (fsym->attr.proc_pointer
&& e->expr_type == EXPR_VARIABLE
&& gfc_is_proc_ptr_comp (e, NULL))
&& gfc_is_proc_ptr_comp (e))
|| (fsym->attr.allocatable
&& fsym->attr.flavor != FL_PROCEDURE)))
{
@ -6007,7 +6007,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
&& !expr1->ts.deferred
&& !expr1->symtree->n.sym->attr.proc_pointer
&& !gfc_is_proc_ptr_comp (expr1, NULL))
&& !gfc_is_proc_ptr_comp (expr1))
{
gcc_assert (expr2->ts.type == BT_CHARACTER);
gcc_assert (lse.string_length && rse.string_length);
@ -6700,9 +6700,9 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
functions. */
comp = gfc_get_proc_ptr_comp (expr2);
gcc_assert (expr2->value.function.isym
|| (gfc_is_proc_ptr_comp (expr2, &comp)
&& comp && comp->attr.dimension)
|| (comp && comp->attr.dimension)
|| (!comp && gfc_return_by_reference (expr2->value.function.esym)
&& expr2->value.function.esym->result->attr.dimension));

2
gcc/fortran/trans-io.c
View File

@ -2252,7 +2252,7 @@ gfc_trans_transfer (gfc_code * code)
/* Transfer an array. If it is an array of an intrinsic
type, pass the descriptor to the library. Otherwise
scalarize the transfer. */
if (expr->ref && !gfc_is_proc_ptr_comp (expr, NULL))
if (expr->ref && !gfc_is_proc_ptr_comp (expr))
{
for (ref = expr->ref; ref && ref->type != REF_ARRAY;
ref = ref->next);