OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/55763 (Issues with some simpler CLASS(*) programs) 

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>

        PR fortran/55763
        * gfortran.dg/pointer_init_2.f90: Update dg-error.
        * gfortran.dg/pointer_init_7.f90: New.

From-SVN: r194990
This commit is contained in:
Tobias Burnus 2013-01-07 19:30:11 +01:00 committed by Tobias Burnus
parent 7f7162cf57
commit e35e87dc46
8 changed files with 161 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/fortran/ChangeLog
View File

@ -1,3 +1,15 @@
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>

6
gcc/fortran/decl.c
View File

@ -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;

63
gcc/fortran/expr.c
View File

@ -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 && 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",
@ -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);

2
gcc/fortran/gfortran.h
View File

@ -2770,7 +2770,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 *);

27
gcc/fortran/resolve.c
View File

@ -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
@ -10450,7 +10455,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);
}
@ -12874,6 +12879,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);

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
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 *.

27
gcc/testsuite/gfortran.dg/pointer_init_2.f90
View File

@ -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" }
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 t
type(t) ::u
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" }
end type t5
type t6
integer, pointer :: dpc5 => a ! { dg-error "must not be ALLOCATABLE" }
end type t6
end subroutine

56
gcc/testsuite/gfortran.dg/pointer_init_7.f90 Normal file
View File

@ -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