diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 3adaabc2ead..cfc71c19991 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,29 @@ +2010-08-19 Janus Weil + + PR fortran/45290 + * gfortran.h (gfc_add_save): Modified prototype. + * decl.c (add_init_expr_to_sym): Defer checking of proc pointer init. + (match_pointer_init): New function to match F08 pointer initialization. + (variable_decl,match_procedure_decl,match_ppc_decl): Use + 'match_pointer_init'. + (match_attr_spec): Module variables are implicitly SAVE. + (gfc_match_save): Modified call to 'gfc_add_save'. + * expr.c (gfc_check_assign_symbol): Extra checks for pointer + initialization. + * primary.c (gfc_variable_attr): Handle SAVE attribute. + * resolve.c (resolve_structure_cons): Add new argument and do pointer + initialization checks. + (gfc_resolve_expr): Modified call to 'resolve_structure_cons'. + (resolve_values): Call 'resolve_structure_cons' directly with init arg. + (resolve_fl_variable): Handle SAVE_IMPLICIT. + * symbol.c (gfc_add_save,gfc_copy_attr,save_symbol): Handle + SAVE_IMPLICIT. + * trans-decl.c (gfc_create_module_variable): Module variables with + TARGET can already exist. + * trans-expr.c (gfc_conv_variable): Check for 'current_function_decl'. + (gfc_conv_initializer): Implement non-NULL pointer + initialization. + 2010-08-18 Tobias Burnus PR fortran/45295 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 5baa400f0ac..5b4ab182ed7 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1312,9 +1312,10 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) } /* Check if the assignment can happen. This has to be put off - until later for a derived type variable. */ + until later for derived type variables and procedure pointers. */ if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS + && !sym->attr.proc_pointer && gfc_check_assign_symbol (sym, init) == FAILURE) return FAILURE; @@ -1652,6 +1653,48 @@ gfc_match_null (gfc_expr **result) } +/* Match the initialization expr for a data pointer or procedure pointer. */ + +static match +match_pointer_init (gfc_expr **init, int procptr) +{ + match m; + + if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED) + { + gfc_error ("Initialization of pointer at %C is not allowed in " + "a PURE procedure"); + return MATCH_ERROR; + } + + /* Match NULL() initilization. */ + m = gfc_match_null (init); + if (m != MATCH_NO) + return m; + + /* Match non-NULL initialization. */ + gfc_matching_procptr_assignment = procptr; + m = gfc_match_rvalue (init); + gfc_matching_procptr_assignment = 0; + if (m == MATCH_ERROR) + return MATCH_ERROR; + else if (m == MATCH_NO) + { + gfc_error ("Error in pointer initialization at %C"); + return MATCH_ERROR; + } + + if (!procptr) + gfc_resolve_expr (*init); + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: non-NULL pointer " + "initialization at %C") == FAILURE) + return MATCH_ERROR; + + return MATCH_YES; +} + + /* Match a variable name with an optional initializer. When this subroutine is called, a variable is expected to be parsed next. Depending on what is happening at the moment, updates either the @@ -1899,23 +1942,9 @@ variable_decl (int elem) goto cleanup; } - m = gfc_match_null (&initializer); - if (m == MATCH_NO) - { - gfc_error ("Pointer initialization requires a NULL() at %C"); - m = MATCH_ERROR; - } - - if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED) - { - gfc_error ("Initialization of pointer at %C is not allowed in " - "a PURE procedure"); - m = MATCH_ERROR; - } - + m = match_pointer_init (&initializer, 0); if (m != MATCH_YES) goto cleanup; - } else if (gfc_match_char ('=') == MATCH_YES) { @@ -3511,7 +3540,7 @@ match_attr_spec (void) break; case DECL_SAVE: - t = gfc_add_save (¤t_attr, NULL, &seen_at[d]); + t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]); break; case DECL_TARGET: @@ -3551,6 +3580,10 @@ match_attr_spec (void) } } + /* Module variables implicitly have the SAVE attribute. */ + if (gfc_current_state () == COMP_MODULE && !current_attr.save) + current_attr.save = SAVE_IMPLICIT; + colon_seen = 1; return MATCH_YES; @@ -4675,20 +4708,7 @@ match_procedure_decl (void) goto cleanup; } - m = gfc_match_null (&initializer); - if (m == MATCH_NO) - { - gfc_error ("Pointer initialization requires a NULL() at %C"); - m = MATCH_ERROR; - } - - if (gfc_pure (NULL)) - { - gfc_error ("Initialization of pointer at %C is not allowed in " - "a PURE procedure"); - m = MATCH_ERROR; - } - + m = match_pointer_init (&initializer, 1); if (m != MATCH_YES) goto cleanup; @@ -4815,18 +4835,7 @@ match_ppc_decl (void) if (gfc_match (" =>") == MATCH_YES) { - m = gfc_match_null (&initializer); - if (m == MATCH_NO) - { - gfc_error ("Pointer initialization requires a NULL() at %C"); - m = MATCH_ERROR; - } - if (gfc_pure (NULL)) - { - gfc_error ("Initialization of pointer at %C is not allowed in " - "a PURE procedure"); - m = MATCH_ERROR; - } + m = match_pointer_init (&initializer, 1); if (m != MATCH_YES) { gfc_free_expr (initializer); @@ -6720,8 +6729,8 @@ gfc_match_save (void) switch (m) { case MATCH_YES: - if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus) - == FAILURE) + if (gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, + &gfc_current_locus) == FAILURE) return MATCH_ERROR; goto next_item; diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index b3f64536716..3d9f6dc61bf 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3552,7 +3552,35 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) gfc_free (lvalue.symtree); - return r; + if (r == FAILURE) + return r; + + if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL) + { + /* F08:C461. Additional checks for pointer initialization. */ + symbol_attribute attr; + attr = gfc_expr_attr (rvalue); + if (attr.allocatable) + { + gfc_error ("Pointer initialization target at %C " + "must not be ALLOCATABLE "); + return FAILURE; + } + if (!attr.target) + { + gfc_error ("Pointer initialization target at %C " + "must have the TARGET attribute"); + return FAILURE; + } + if (!attr.save) + { + gfc_error ("Pointer initialization target at %C " + "must have the SAVE attribute"); + return FAILURE; + } + } + + return SUCCESS; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index c9634d3ee91..89a8e504711 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2466,7 +2466,7 @@ gfc_try gfc_add_cray_pointee (symbol_attribute *, locus *); match gfc_mod_pointee_as (gfc_array_spec *); gfc_try gfc_add_protected (symbol_attribute *, const char *, locus *); gfc_try gfc_add_result (symbol_attribute *, const char *, locus *); -gfc_try gfc_add_save (symbol_attribute *, const char *, locus *); +gfc_try gfc_add_save (symbol_attribute *, save_state, const char *, locus *); gfc_try gfc_add_threadprivate (symbol_attribute *, const char *, locus *); gfc_try gfc_add_saved_common (symbol_attribute *, locus *); gfc_try gfc_add_target (symbol_attribute *, locus *); diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 8b5bc148c2a..63889856604 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2088,6 +2088,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) attr.pointer = pointer; attr.allocatable = allocatable; attr.target = target; + attr.save = sym->attr.save; return attr; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d6da043dcfb..f770f601115 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -833,10 +833,11 @@ resolve_contained_functions (gfc_namespace *ns) /* Resolve all of the elements of a structure constructor and make sure that - the types are correct. */ + the types are correct. The 'init' flag indicates that the given + constructor is an initializer. */ static gfc_try -resolve_structure_cons (gfc_expr *expr) +resolve_structure_cons (gfc_expr *expr, int init) { gfc_constructor *cons; gfc_component *comp; @@ -896,7 +897,8 @@ resolve_structure_cons (gfc_expr *expr) /* If we don't have the right type, try to convert it. */ - if (!gfc_compare_types (&cons->expr->ts, &comp->ts)) + if (!comp->attr.proc_pointer && + !gfc_compare_types (&cons->expr->ts, &comp->ts)) { t = FAILURE; if (strcmp (comp->name, "$extends") == 0) @@ -1005,6 +1007,23 @@ resolve_structure_cons (gfc_expr *expr) "a TARGET", &cons->expr->where, comp->name); } + if (init) + { + /* F08:C461. Additional checks for pointer initialization. */ + if (a.allocatable) + { + t = FAILURE; + gfc_error ("Pointer initialization target at %L " + "must not be ALLOCATABLE ", &cons->expr->where); + } + if (!a.save) + { + t = FAILURE; + gfc_error ("Pointer initialization target at %L " + "must have the SAVE attribute", &cons->expr->where); + } + } + /* F2003, C1272 (3). */ if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE && (gfc_impure_variable (cons->expr->symtree->n.sym) @@ -1015,6 +1034,7 @@ resolve_structure_cons (gfc_expr *expr) "pointer component '%s' at %L in PURE procedure", comp->name, &cons->expr->where); } + } return t; @@ -5977,7 +5997,7 @@ gfc_resolve_expr (gfc_expr *e) if (t == FAILURE) break; - t = resolve_structure_cons (e); + t = resolve_structure_cons (e, 0); if (t == FAILURE) break; @@ -8924,10 +8944,17 @@ resolve_code (gfc_code *code, gfc_namespace *ns) static void resolve_values (gfc_symbol *sym) { + gfc_try t; + if (sym->value == NULL) return; - if (gfc_resolve_expr (sym->value) == FAILURE) + if (sym->value->expr_type == EXPR_STRUCTURE) + t= resolve_structure_cons (sym->value, 1); + else + t = gfc_resolve_expr (sym->value); + + if (t == FAILURE) return; gfc_check_assign_symbol (sym, sym->value); @@ -9636,7 +9663,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) return FAILURE; } - if (e && sym->attr.save && !gfc_is_constant_expr (e)) + if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e)) { gfc_error (auto_save_msg, sym->name, &sym->declared_at); return FAILURE; diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 0199ac42144..4d3db861053 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1095,13 +1095,14 @@ gfc_add_result (symbol_attribute *attr, const char *name, locus *where) gfc_try -gfc_add_save (symbol_attribute *attr, const char *name, locus *where) +gfc_add_save (symbol_attribute *attr, save_state s, const char *name, + locus *where) { if (check_used (attr, name, where)) return FAILURE; - if (gfc_pure (NULL)) + if (s == SAVE_EXPLICIT && gfc_pure (NULL)) { gfc_error ("SAVE attribute at %L cannot be specified in a PURE procedure", @@ -1109,7 +1110,7 @@ gfc_add_save (symbol_attribute *attr, const char *name, locus *where) return FAILURE; } - if (attr->save == SAVE_EXPLICIT && !attr->vtab) + if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT) { if (gfc_notify_std (GFC_STD_LEGACY, "Duplicate SAVE attribute specified at %L", @@ -1118,7 +1119,7 @@ gfc_add_save (symbol_attribute *attr, const char *name, locus *where) return FAILURE; } - attr->save = SAVE_EXPLICIT; + attr->save = s; return check_conflict (attr, name, where); } @@ -1740,7 +1741,7 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) goto fail; if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE) goto fail; - if (src->save && gfc_add_save (dest, NULL, where) == FAILURE) + if (src->save && gfc_add_save (dest, src->save, NULL, where) == FAILURE) goto fail; if (src->value && gfc_add_value (dest, NULL, where) == FAILURE) goto fail; @@ -3430,7 +3431,7 @@ save_symbol (gfc_symbol *sym) /* Automatic objects are not saved. */ if (gfc_is_var_automatic (sym)) return; - gfc_add_save (&sym->attr, sym->name, &sym->declared_at); + gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at); } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 1abb0596e7e..f3e29502054 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3587,7 +3587,7 @@ gfc_create_module_variable (gfc_symbol * sym) && (sym->equiv_built || sym->attr.in_equivalence)) return; - if (sym->backend_decl && !sym->attr.vtab) + if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target) internal_error ("backend decl for module variable %s already exists", sym->name); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 4465832d847..810212ba9cf 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -556,7 +556,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) { gfc_ref *ref; gfc_symbol *sym; - tree parent_decl; + tree parent_decl = NULL_TREE; int parent_flag; bool return_value; bool alternate_entry; @@ -590,7 +590,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) entry_master = sym->attr.result && sym->ns->proc_name->attr.entry_master && !gfc_return_by_reference (sym->ns->proc_name); - parent_decl = DECL_CONTEXT (current_function_decl); + if (current_function_decl) + parent_decl = DECL_CONTEXT (current_function_decl); if ((se->expr == parent_decl && return_value) || (sym->ns && sym->ns->proc_name @@ -3983,7 +3984,17 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, return gfc_conv_array_initializer (type, expr); } else if (pointer) - return fold_convert (type, null_pointer_node); + { + if (!expr || expr->expr_type == EXPR_NULL) + return fold_convert (type, null_pointer_node); + else + { + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, expr); + return se.expr; + } + } else { switch (ts->type) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 32f4228df45..d033f9a9d57 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2010-08-19 Janus Weil + + PR fortran/45290 + * gfortran.dg/proc_ptr_comp_3.f90: Modified. + * gfortran.dg/pointer_init_2.f90: New. + * gfortran.dg/pointer_init_3.f90: New. + * gfortran.dg/pointer_init_4.f90: New. + 2010-08-18 Nathan Froyd PR c++/45049 diff --git a/gcc/testsuite/gfortran.dg/pointer_init_2.f90 b/gcc/testsuite/gfortran.dg/pointer_init_2.f90 new file mode 100644 index 00000000000..8f72663e259 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_init_2.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! PR 45290: [F08] pointer initialization +! +! Contributed by Janus Weil + +subroutine sub + implicit none + + real, target, save :: r + integer, target, save, dimension(1:3) :: v + + integer, save :: i + integer, target :: j + integer, target, save, allocatable :: a + + + integer, pointer :: dp0 => 13 ! { dg-error "Error in pointer initialization" } + integer, pointer :: dp1 => r ! { dg-error "Different types in pointer assignment" } + integer, pointer :: dp2 => v ! { dg-error "Different ranks in pointer assignment" } + integer, pointer :: dp3 => i ! { dg-error "is neither TARGET nor POINTER" } + integer, pointer :: dp4 => j ! { dg-error "must have the SAVE attribute" } + integer, pointer :: dp5 => a ! { dg-error "must not be ALLOCATABLE" } + + type :: t + integer, pointer :: dpc0 => 13 ! { dg-error "Error in pointer initialization" } + integer, pointer :: dpc1 => r ! { dg-error "is REAL but should be INTEGER" } + integer, pointer :: dpc2 => v ! { dg-error "rank of the element.*does not match" } + integer, pointer :: dpc3 => i ! { dg-error "should be a POINTER or a TARGET" } + integer, pointer :: dpc4 => j ! { dg-error "must have the SAVE attribute" } + integer, pointer :: dpc5 => a ! { dg-error "must not be ALLOCATABLE" } + end type + + type(t) ::u + +end subroutine diff --git a/gcc/testsuite/gfortran.dg/pointer_init_3.f90 b/gcc/testsuite/gfortran.dg/pointer_init_3.f90 new file mode 100644 index 00000000000..867a428bf48 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_init_3.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! +! PR 45290: [F08] pointer initialization +! +! Contributed by Janus Weil + +module m + integer, target :: t1 ! SAVE is implicit + integer, pointer :: p1 => t1 +end module m + + +use m +implicit none + +integer,target :: i0 = 2 +integer,target,dimension(1:3) :: vec = 1 + +type :: t + integer, pointer :: dpc => i0 + integer :: i = 0 +end type + +type (t), save, target :: u + +integer, pointer :: dp => i0 +integer, pointer :: dp2 => vec(2) +integer, pointer :: dp3 => u%i + +dp = 5 +if (i0/=5) call abort() + +u%dpc = 6 +if (i0/=6) call abort() + +dp2 = 3 +if (vec(2)/=3) call abort() + +dp3 = 4 +if (u%i/=4) call abort() + +end + +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/pointer_init_4.f90 b/gcc/testsuite/gfortran.dg/pointer_init_4.f90 new file mode 100644 index 00000000000..75ead452917 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_init_4.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! +! PR 45290: [F08] pointer initialization +! +! Contributed by Janus Weil + +module m + +implicit none + +contains + + integer function f1() + f1 = 42 + end function + + integer function f2() + f2 = 43 + end function + +end module + + +program test_ptr_init + +use m +implicit none + +procedure(f1), pointer :: pp => f1 + +type :: t + procedure(f2), pointer, nopass :: ppc => f2 +end type + +type (t) :: u + +if (pp()/=42) call abort() +if (u%ppc()/=43) call abort() + +end + +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 index fc8c28da32e..4b866c0c562 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 @@ -22,7 +22,6 @@ type :: t procedure(), pointer, nopass ptr4 ! { dg-error "Expected '::'" } procedure(), pointer, nopass, pointer :: ptr5 ! { dg-error "Duplicate" } procedure, pointer, nopass :: ptr6 ! { dg-error "Syntax error" } - procedure(), pointer, nopass :: ptr7 => ptr2 ! { dg-error "requires a NULL" } procedure(), nopass :: ptr8 ! { dg-error "POINTER attribute is required" } procedure(pp), pointer, nopass :: ptr9 ! { dg-error "declared in a later PROCEDURE statement" } procedure(aaargh), pointer, nopass :: ptr10 ! { dg-error "must be explicit" }