diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 12 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 22 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 3 | ||||
| -rw-r--r-- | gcc/fortran/primary.c | 11 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 15 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/proc_ptr_37.f90 | 15 |
7 files changed, 71 insertions, 12 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0c0ffe0..4974cb3 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index cb5e1c6..f43bc6f 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index e1f2e3c..063959a 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 */ diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index e2c3f99..29d2789 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.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; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 370e5cd..25c6c8e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 442aa3f..1ee6947 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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 diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_37.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_37.f90 new file mode 100644 index 0000000..485e76f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_37.f90 @@ -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 |