2013-01-04 Tobias Burnus <burnus@net-b.de>
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 <burnus@net-b.de>
PR fortran/55763
* gfortran.dg/pointer_init_2.f90: Update dg-error.
* gfortran.dg/pointer_init_7.f90: New.
@@ -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;
@@ -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);
@@ -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 *);
@@ -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);
@@ -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
new file mode 100644
@@ -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
Fortran 2008 allows: integer :: pointer => init_data and type t integer :: pointer => init_data end type t The current check in gfc_check_assign_symbol was only called for former and for constructors, but not for the type definition. Additionally, BT_CLASS wasn't handled. I also improved the error location. The patch has a downside: One gets some messages twice or trice: Once for resolving the type declaration ("type t") and then for resolving the default initialization via gfc_traverse_ns (ns, resolve_values); Currently, that's unavoidable as one cannot trivially distinguish between a user-supplied "sym->value" and the default constructor. If you think that this is a problem, one can change it, e.g. by setting a sym->attr.value_is_default_init. Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias PS: For CLASS pointers, there will be an ICE if one tries to associate a variable to them; that's unchanged by this patch.