diff options
Diffstat (limited to 'gcc/fortran/expr.c')
| -rw-r--r-- | gcc/fortran/expr.c | 68 |
1 files changed, 61 insertions, 7 deletions
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index c70d4d1e7a1..feaa6254840 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -182,6 +182,7 @@ free_expr0 (gfc_expr *e) break; case EXPR_COMPCALL: + case EXPR_PPC: gfc_free_actual_arglist (e->value.compcall.actual); break; @@ -507,6 +508,7 @@ gfc_copy_expr (gfc_expr *p) break; case EXPR_COMPCALL: + case EXPR_PPC: q->value.compcall.actual = gfc_copy_actual_arglist (p->value.compcall.actual); q->value.compcall.tbp = p->value.compcall.tbp; @@ -1728,6 +1730,7 @@ gfc_simplify_expr (gfc_expr *p, int type) break; case EXPR_COMPCALL: + case EXPR_PPC: gcc_unreachable (); break; } @@ -3038,7 +3041,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) symbol_attribute attr; gfc_ref *ref; int is_pure; - int pointer, check_intent_in; + int pointer, check_intent_in, proc_pointer; if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN && !lvalue->symtree->n.sym->attr.proc_pointer) @@ -3062,16 +3065,19 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) /* Check INTENT(IN), unless the object itself is the component or sub-component of a pointer. */ check_intent_in = 1; - pointer = lvalue->symtree->n.sym->attr.pointer - | lvalue->symtree->n.sym->attr.proc_pointer; + pointer = lvalue->symtree->n.sym->attr.pointer; + proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer; for (ref = lvalue->ref; ref; ref = ref->next) { if (pointer) check_intent_in = 0; - if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) - pointer = 1; + if (ref->type == REF_COMPONENT) + { + pointer = ref->u.c.component->attr.pointer; + proc_pointer = ref->u.c.component->attr.proc_pointer; + } if (ref->type == REF_ARRAY && ref->next == NULL) { @@ -3107,7 +3113,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return FAILURE; } - if (!pointer) + if (!pointer && !proc_pointer) { gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where); return FAILURE; @@ -3129,11 +3135,12 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return SUCCESS; /* Checks on rvalue for procedure pointer assignments. */ - if (lvalue->symtree->n.sym->attr.proc_pointer) + if (proc_pointer) { attr = gfc_expr_attr (rvalue); if (!((rvalue->expr_type == EXPR_NULL) || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer) + || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer) || (rvalue->expr_type == EXPR_VARIABLE && attr.flavor == FL_PROCEDURE))) { @@ -3148,6 +3155,25 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) rvalue->symtree->name, &rvalue->where); return FAILURE; } + /* Check for C727. */ + if (attr.flavor == FL_PROCEDURE) + { + if (attr.proc == PROC_ST_FUNCTION) + { + gfc_error ("Statement function '%s' is invalid " + "in procedure pointer assignment at %L", + rvalue->symtree->name, &rvalue->where); + return FAILURE; + } + if (attr.proc == PROC_INTERNAL && + gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is " + "invalid in procedure pointer assignment at %L", + rvalue->symtree->name, &rvalue->where) == FAILURE) + return FAILURE; + } + /* TODO: Enable interface check for PPCs. */ + if (is_proc_ptr_comp (rvalue, NULL)) + return SUCCESS; if (rvalue->expr_type == EXPR_VARIABLE && !gfc_compare_interfaces (lvalue->symtree->n.sym, rvalue->symtree->n.sym, 0)) @@ -3481,6 +3507,34 @@ 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). */ + +bool +is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp) +{ + gfc_ref *ref; + bool ppc = false; + + if (!expr || !expr->ref) + return false; + + 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; + } + + return ppc; +} + + /* Walk an expression tree and check each variable encountered for being typed. If strict is not set, a top-level variable is tolerated untyped in -std=gnu mode as is a basic arithmetic expression using those; this is for things in |