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

re PR fortran/41608 ([OOP] ICE with CLASS and invalid code)

Browse Source 
2009-10-17  Janus Weil  <janus@gcc.gnu.org>
	    Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/41608
	* decl.c (gfc_match_data_decl): Add BT_CLASS for undefined type
	and empty type errors.
	* parse.c (gfc_build_block_ns): Only set recursive if parent ns
	has a proc_name.

	PR fortran/41629
	PR fortran/41618
	PR fortran/41587
	* gfortran.h : Add class_ok bitfield to symbol_attr.
	* decl.c (build_sym): Set attr.class_ok if dummy, pointer or
	allocatable.
	(build_struct): Use gfc_try 't' to carry errors past the call
	to encapsulate_class_symbol.
	(attr_decl1): For a CLASS object, apply the new attribute to
	the data component.
	* match.c (gfc_match_select_type): Set attr.class_ok for an
	assigned selector.
	* resolve.c (resolve_fl_variable_derived): Check a CLASS object
	is dummy, pointer or allocatable by testing the class_ok and
	the use_assoc attribute.

2009-10-17  Janus Weil  <janus@gcc.gnu.org>
	    Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/41629
	* gfortran.dg/class_6.f90: New test.

	PR fortran/41608
	PR fortran/41587
	* gfortran.dg/class_7.f90: New test.

	PR fortran/41618
	* gfortran.dg/class_8.f90: New test.


Co-Authored-By: Paul Thomas <pault@gcc.gnu.org>

From-SVN: r152955
This commit is contained in:
Janus Weil 2009-10-17 20:09:25 +02:00 committed by Paul Thomas
parent 1ee41d433d
commit 2e23972ecb
10 changed files with 147 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
gcc/fortran/ChangeLog
View File

@ -1,3 +1,28 @@
2009-10-17 Janus Weil <janus@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
PR fortran/41608
* decl.c (gfc_match_data_decl): Add BT_CLASS for undefined type
and empty type errors.
* parse.c (gfc_build_block_ns): Only set recursive if parent ns
has a proc_name.
PR fortran/41629
PR fortran/41618
PR fortran/41587
* gfortran.h : Add class_ok bitfield to symbol_attr.
* decl.c (build_sym): Set attr.class_ok if dummy, pointer or
allocatable.
(build_struct): Use gfc_try 't' to carry errors past the call
to encapsulate_class_symbol.
(attr_decl1): For a CLASS object, apply the new attribute to
the data component.
* match.c (gfc_match_select_type): Set attr.class_ok for an
assigned selector.
* resolve.c (resolve_fl_variable_derived): Check a CLASS object
is dummy, pointer or allocatable by testing the class_ok and
the use_assoc attribute.
2009-10-16 Janus Weil <janus@gcc.gnu.org>
PR fortran/41719

61
gcc/fortran/decl.c
View File

@ -1181,7 +1181,12 @@ build_sym (const char *name, gfc_charlen *cl,
sym->attr.implied_index = 0;
if (sym->ts.type == BT_CLASS)
encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
{
sym->attr.class_ok = (sym->attr.dummy
|| sym->attr.pointer
|| sym->attr.allocatable) ? 1 : 0;
encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
}
return SUCCESS;
}
@ -1472,6 +1477,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
gfc_array_spec **as)
{
gfc_component *c;
gfc_try t = SUCCESS;
/* F03:C438/C439. If the current symbol is of the same derived type that we're
constructing, it must have the pointer attribute. */
@ -1554,12 +1560,9 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
}
}
if (c->ts.type == BT_CLASS)
encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
/* Check array components. */
if (!c->attr.dimension)
return SUCCESS;
goto scalar;
if (c->attr.pointer)
{
@ -1567,7 +1570,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
{
gfc_error ("Pointer array component of structure at %C must have a "
"deferred shape");
return FAILURE;
t = FAILURE;
}
}
else if (c->attr.allocatable)
@ -1576,7 +1579,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
{
gfc_error ("Allocatable component of structure at %C must have a "
"deferred shape");
return FAILURE;
t = FAILURE;
}
}
else
@ -1585,11 +1588,15 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
{
gfc_error ("Array component of structure at %C must have an "
"explicit shape");
return FAILURE;
t = FAILURE;
}
}
return SUCCESS;
scalar:
if (c->ts.type == BT_CLASS)
encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
return t;
}
@ -3761,7 +3768,8 @@ gfc_match_data_decl (void)
if (m != MATCH_YES)
return m;
if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
&& gfc_current_state () != COMP_DERIVED)
{
sym = gfc_use_derived (current_ts.u.derived);
@ -3781,7 +3789,8 @@ gfc_match_data_decl (void)
goto cleanup;
}
if (current_ts.type == BT_DERIVED && current_ts.u.derived->components == NULL
if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
&& current_ts.u.derived->components == NULL
&& !current_ts.u.derived->attr.zero_comp)
{
@ -5694,13 +5703,31 @@ attr_decl1 (void)
}
}
/* Update symbol table. DIMENSION attribute is set
in gfc_set_array_spec(). */
if (current_attr.dimension == 0
&& gfc_copy_attr (&sym->attr, &current_attr, &var_locus) == FAILURE)
/* Update symbol table. DIMENSION attribute is set in
gfc_set_array_spec(). For CLASS variables, this must be applied
to the first component, or '$data' field. */
if (sym->ts.type == BT_CLASS && sym->ts.u.derived)
{
m = MATCH_ERROR;
goto cleanup;
gfc_component *comp;
comp = gfc_find_component (sym->ts.u.derived, "$data", true, true);
if (comp == NULL || gfc_copy_attr (&comp->attr, &current_attr,
&var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
sym->attr.class_ok = (sym->attr.class_ok
|| current_attr.allocatable
|| current_attr.pointer);
}
else
{
if (current_attr.dimension == 0
&& gfc_copy_attr (&sym->attr, &current_attr, &var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
}
if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)

1
gcc/fortran/gfortran.h
View File

@ -672,6 +672,7 @@ typedef struct
unsigned is_bind_c:1; /* say if is bound to C. */
unsigned extension:1; /* extends a derived type. */
unsigned is_class:1; /* is a CLASS container. */
unsigned class_ok:1; /* is a CLASS object with correct attributes. */
/* These flags are both in the typespec and attribute. The attribute
list is what gets read from/written to a module file. The typespec

1
gcc/fortran/match.c
View File

@ -4080,6 +4080,7 @@ gfc_match_select_type (void)
return MATCH_ERROR;
expr1->symtree->n.sym->ts = expr2->ts;
expr1->symtree->n.sym->attr.referenced = 1;
expr1->symtree->n.sym->attr.class_ok = 1;
}
else
{

4
gcc/fortran/parse.c
View File

@ -3069,7 +3069,9 @@ gfc_build_block_ns (gfc_namespace *parent_ns)
my_ns->proc_name->name, NULL);
gcc_assert (t == SUCCESS);
}
my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
if (parent_ns->proc_name)
my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
return my_ns;
}

5
gcc/fortran/resolve.c
View File

@ -8641,9 +8641,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
}
/* C509. */
if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer
|| sym->ts.u.derived->components->attr.allocatable
|| sym->ts.u.derived->components->attr.pointer))
/* Assume that use associated symbols were checked in the module ns. */
if (!sym->attr.class_ok && !sym->attr.use_assoc)
{
gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
"or pointer", sym->name, &sym->declared_at);

13
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,16 @@
2009-10-17 Janus Weil <janus@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
PR fortran/41629
* gfortran.dg/class_6.f90: New test.
PR fortran/41608
PR fortran/41587
* gfortran.dg/class_7.f90: New test.
PR fortran/41618
* gfortran.dg/class_8.f90: New test.
2009-10-17 Richard Guenther <rguenther@suse.de>
* gcc.dg/lto/20091017-1_0.c: New testcase.

21
gcc/testsuite/gfortran.dg/class_6.f03 Normal file
View File

@ -0,0 +1,21 @@
! { dg-do run }
!
! PR 41629: [OOP] gimplification error on valid code
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
type t1
integer :: comp
end type
type(t1), target :: a
class(t1) :: x
pointer :: x ! This is valid
a%comp = 3
x => a
print *,x%comp
if (x%comp/=3) call abort()
end

21
gcc/testsuite/gfortran.dg/class_7.f03 Normal file
View File

@ -0,0 +1,21 @@
! { dg-do compile }
! Test fixes for PR41587 and PR41608.
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
!
! PR41587: used to accept the declaration of component 'foo'
type t0
integer :: j = 42
end type t0
type t
integer :: i
class(t0), allocatable :: foo(3) ! { dg-error "deferred shape" }
end type t
! PR41608: Would ICE on missing type decl
class(t1), pointer :: c ! { dg-error "before it is defined" }
select type (c) ! { dg-error "shall be polymorphic" }
type is (t1) ! { dg-error "Unexpected" }
end select ! { dg-error "Expecting END PROGRAM" }
end

16
gcc/testsuite/gfortran.dg/class_8.f03 Normal file
View File

@ -0,0 +1,16 @@
! { dg-do compile }
! Test fixes for PR41618.
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
!
type t1
integer :: comp
class(t1),pointer :: cc
end type
class(t1) :: x ! { dg-error "must be dummy, allocatable or pointer" }
x%comp = 3
print *,x%comp
end