2013-01-04 Tobias Burnus PR fortran/55763 * gfortran.h (gfc_check_assign_symbol): Update prototype. * decl.c (add_init_expr_to_sym, do_parm): Update call. * expr.c (gfc_check_assign_symbol): Handle BT_CLASS and improve error location; support components. (gfc_check_pointer_assign): Handle component assignments. * resolve.c (resolve_fl_derived0): Call gfc_check_assign_symbol. (resolve_values): Update call. (resolve_structure_cons): Avoid double diagnostic. 2013-01-04 Tobias Burnus PR fortran/55763 * gfortran.dg/pointer_init_2.f90: Update dg-error. * gfortran.dg/pointer_init_7.f90: New. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index fc86efb..5952b70 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1353,14 +1353,14 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) 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) + && gfc_check_assign_symbol (sym, NULL, init) == FAILURE) return FAILURE; if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl && init->ts.type == BT_CHARACTER) { /* Update symbol character length according initializer. */ - if (gfc_check_assign_symbol (sym, init) == FAILURE) + if (gfc_check_assign_symbol (sym, NULL, init) == FAILURE) return FAILURE; if (sym->ts.u.cl->length == NULL) @@ -6955,7 +6955,7 @@ do_parm (void) goto cleanup; } - if (gfc_check_assign_symbol (sym, init) == FAILURE + if (gfc_check_assign_symbol (sym, NULL, init) == FAILURE || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE) { m = MATCH_ERROR; diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 2610784..146154e 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3291,22 +3291,21 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) gfc_try gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { - symbol_attribute attr; + symbol_attribute attr, lhs_attr; gfc_ref *ref; bool is_pure, is_implicit_pure, rank_remap; int proc_pointer; - if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN - && !lvalue->symtree->n.sym->attr.proc_pointer) + lhs_attr = gfc_expr_attr (lvalue); + if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer) { gfc_error ("Pointer assignment target is not a POINTER at %L", &lvalue->where); return FAILURE; } - if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE - && lvalue->symtree->n.sym->attr.use_assoc - && !lvalue->symtree->n.sym->attr.proc_pointer) + if (lhs_attr.flavor == FL_PROCEDURE && lvalue->symtree->n.sym->attr.use_assoc + && !lhs_attr.proc_pointer) { gfc_error ("'%s' in the pointer assignment at %L cannot be an " "l-value since it is a procedure", @@ -3735,10 +3734,11 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) symbol. Used for initialization assignments. */ gfc_try -gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) +gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) { gfc_expr lvalue; gfc_try r; + bool pointer, proc_pointer; memset (&lvalue, '\0', sizeof (gfc_expr)); @@ -3750,9 +3750,27 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) lvalue.symtree->n.sym = sym; lvalue.where = sym->declared_at; - if (sym->attr.pointer || sym->attr.proc_pointer - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer - && rvalue->expr_type == EXPR_NULL)) + if (comp) + { + lvalue.ref = gfc_get_ref (); + lvalue.ref->type = REF_COMPONENT; + lvalue.ref->u.c.component = comp; + lvalue.ref->u.c.sym = sym; + lvalue.ts = comp->ts; + lvalue.rank = comp->as ? comp->as->rank : 0; + lvalue.where = comp->loc; + pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp) + ? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer; + proc_pointer = comp->attr.proc_pointer; + } + else + { + pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym) + ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer; + proc_pointer = sym->attr.proc_pointer; + } + + if (pointer || proc_pointer) r = gfc_check_pointer_assign (&lvalue, rvalue); else r = gfc_check_assign (&lvalue, rvalue, 1); @@ -3762,32 +3780,41 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) if (r == FAILURE) return r; - if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL) + if (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 "); + gfc_error ("Pointer initialization target at %L " + "must not be ALLOCATABLE", &rvalue->where); return FAILURE; } if (!attr.target || attr.pointer) { - gfc_error ("Pointer initialization target at %C " - "must have the TARGET attribute"); + gfc_error ("Pointer initialization target at %L " + "must have the TARGET attribute", &rvalue->where); return FAILURE; } + + if (!attr.save && rvalue->expr_type == EXPR_VARIABLE + && rvalue->symtree->n.sym->ns->proc_name + && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program) + { + rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT; + attr.save = SAVE_IMPLICIT; + } + if (!attr.save) { - gfc_error ("Pointer initialization target at %C " - "must have the SAVE attribute"); + gfc_error ("Pointer initialization target at %L " + "must have the SAVE attribute", &rvalue->where); return FAILURE; } } - if (sym->attr.proc_pointer && rvalue->expr_type != EXPR_NULL) + if (proc_pointer && rvalue->expr_type != EXPR_NULL) { /* F08:C1220. Additional checks for procedure pointer initialization. */ symbol_attribute attr = gfc_expr_attr (rvalue); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a419af3..4e6e455 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2769,7 +2769,7 @@ int gfc_kind_max (gfc_expr *, gfc_expr *); gfc_try gfc_check_conformance (gfc_expr *, gfc_expr *, const char *, ...) ATTRIBUTE_PRINTF_3; gfc_try gfc_check_assign (gfc_expr *, gfc_expr *, int); gfc_try gfc_check_pointer_assign (gfc_expr *, gfc_expr *); -gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *); +gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_component *, gfc_expr *); bool gfc_has_default_initializer (gfc_symbol *); gfc_expr *gfc_default_initializer (gfc_typespec *); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 873400a..fcd9f63 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1105,23 +1105,28 @@ resolve_structure_cons (gfc_expr *expr, int init) if (!comp->attr.proc_pointer && !gfc_compare_types (&cons->expr->ts, &comp->ts)) { - t = FAILURE; if (strcmp (comp->name, "_extends") == 0) { /* Can afford to be brutal with the _extends initializer. The derived type can get lost because it is PRIVATE but it is not usage constrained by the standard. */ cons->expr->ts = comp->ts; - t = SUCCESS; } else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN) - gfc_error ("The element in the structure constructor at %L, " - "for pointer component '%s', is %s but should be %s", - &cons->expr->where, comp->name, - gfc_basic_typename (cons->expr->ts.type), - gfc_basic_typename (comp->ts.type)); + { + gfc_error ("The element in the structure constructor at %L, " + "for pointer component '%s', is %s but should be %s", + &cons->expr->where, comp->name, + gfc_basic_typename (cons->expr->ts.type), + gfc_basic_typename (comp->ts.type)); + t = FAILURE; + } else - t = gfc_convert_type (cons->expr, &comp->ts, 1); + { + gfc_try t2 = gfc_convert_type (cons->expr, &comp->ts, 1); + if (t != FAILURE) + t = t2; + } } /* For strings, the length of the constructor should be the same as @@ -10428,7 +10433,7 @@ resolve_values (gfc_symbol *sym) if (t == FAILURE) return; - gfc_check_assign_symbol (sym, sym->value); + gfc_check_assign_symbol (sym, NULL, sym->value); } @@ -12852,6 +12857,10 @@ resolve_fl_derived0 (gfc_symbol *sym) || c->attr.proc_pointer || c->attr.allocatable)) == FAILURE) return FAILURE; + + if (c->initializer && !sym->attr.vtype + && gfc_check_assign_symbol (sym, c, c->initializer) == FAILURE) + return FAILURE; } check_defined_assignments (sym); diff --git a/gcc/testsuite/gfortran.dg/pointer_init_2.f90 b/gcc/testsuite/gfortran.dg/pointer_init_2.f90 index 8f72663..a280a3e 100644 --- a/gcc/testsuite/gfortran.dg/pointer_init_2.f90 +++ b/gcc/testsuite/gfortran.dg/pointer_init_2.f90 @@ -24,13 +24,26 @@ subroutine sub 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" } + end type t + + type t2 + integer, pointer :: dpc1 => r ! { dg-error "attempted assignment of REAL.4. to INTEGER.4." } + end type t2 + + type t3 + integer, pointer :: dpc2 => v ! { dg-error "Different ranks in pointer assignment" } + end type t3 + + type t4 + integer, pointer :: dpc3 => i ! { dg-error "Pointer assignment target is neither TARGET nor POINTER" } + end type t4 + + type t5 integer, pointer :: dpc4 => j ! { dg-error "must have the SAVE attribute" } - integer, pointer :: dpc5 => a ! { dg-error "must not be ALLOCATABLE" } - end type + end type t5 - type(t) ::u + type t6 + integer, pointer :: dpc5 => a ! { dg-error "must not be ALLOCATABLE" } + end type t6 end subroutine diff --git a/gcc/testsuite/gfortran.dg/pointer_init_7.f90 b/gcc/testsuite/gfortran.dg/pointer_init_7.f90 new file mode 100644 index 0000000..dfde615 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_init_7.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! +! PR fortran/55763 +! + +subroutine sub() + type t + integer :: i + end type t + + type(t), target :: tgt + type(t), target, save :: tgt2(2) + + type t2a + type(t), pointer :: cmp1 => tgt ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" } + end type t2a + + type t2b + class(t), pointer :: cmp2 => tgt ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" } + end type t2b + + type t2c + class(t), pointer :: cmp3 => tgt ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" } + end type t2c + + type t2d + integer, pointer :: cmp4 => tgt%i ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" } + end type t2d + + type(t), pointer :: w => tgt ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" } + class(t), pointer :: x => tgt ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" } + class(*), pointer :: y => tgt ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" } + integer, pointer :: z => tgt%i ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" } +end subroutine + +program main + type t3 + integer :: j + end type t3 + + type(t3), target :: tgt + + type t4 + type(t3), pointer :: cmp1 => tgt ! OK + class(t3), pointer :: cmp2 => tgt ! OK + class(t3), pointer :: cmp3 => tgt ! OK + integer, pointer :: cmp4 => tgt%j ! OK + end type t4 + + type(t3), target :: mytarget + + type(t3), pointer :: a => mytarget ! OK + class(t3), pointer :: b => mytarget ! OK + class(*), pointer :: c => mytarget ! OK + integer, pointer :: d => mytarget%j ! OK +end program main