2013-01-07 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-07 Tobias Burnus <burnus@net-b.de>
Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/55852
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)
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;
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 && lhs_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",
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));
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);
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);
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 *);
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
if (t == FAILURE)
return;
- gfc_check_assign_symbol (sym, sym->value);
+ gfc_check_assign_symbol (sym, NULL, sym->value);
}
|| 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);
+2013-01-07 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.
+
2013-01-07 Richard Biener <rguenther@suse.de>
* gcc.dg/lto/pr55525_0.c (s): Size like char *.
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
--- /dev/null
+! { 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
projects / platform / upstream / linaro-gcc.git / commitdiff