diff options
author | Janus Weil <janus@gcc.gnu.org> | 2009-10-17 20:09:25 +0200 |
---|---|---|
committer | Paul Thomas <pault@gcc.gnu.org> | 2009-10-17 18:09:25 +0000 |
commit | 2e23972ecbc374ca535d8fd40d18550e95bdd69d (patch) | |
tree | 03b99fc40494c871043fba245074cae8252f0e8a /gcc | |
parent | 1ee41d433d6d0fe65a719a5bb704de31043b2b78 (diff) | |
download | gcc-2e23972ecbc374ca535d8fd40d18550e95bdd69d.zip gcc-2e23972ecbc374ca535d8fd40d18550e95bdd69d.tar.gz gcc-2e23972ecbc374ca535d8fd40d18550e95bdd69d.tar.bz2 |
re PR fortran/41608 ([OOP] ICE with CLASS and invalid code)
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
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/fortran/ChangeLog | 25 | ||||
-rw-r--r-- | gcc/fortran/decl.c | 61 | ||||
-rw-r--r-- | gcc/fortran/gfortran.h | 1 | ||||
-rw-r--r-- | gcc/fortran/match.c | 1 | ||||
-rw-r--r-- | gcc/fortran/parse.c | 4 | ||||
-rw-r--r-- | gcc/fortran/resolve.c | 5 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 13 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/class_6.f03 | 21 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/class_7.f03 | 21 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/class_8.f03 | 16 |
10 files changed, 147 insertions, 21 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 17bbc06..24e83e6 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 2627e60..08d2bd6 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -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, ¤t_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, ¤t_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, ¤t_attr, &var_locus) == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } } if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index f6b172a..74a31d2 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 3542944..d75ef0e 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -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 { diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 49d449c..c168c52 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -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; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d76c461..285228c 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 223d170..14900619 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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. diff --git a/gcc/testsuite/gfortran.dg/class_6.f03 b/gcc/testsuite/gfortran.dg/class_6.f03 new file mode 100644 index 0000000..2f3ff62 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_6.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/class_7.f03 b/gcc/testsuite/gfortran.dg/class_7.f03 new file mode 100644 index 0000000..ed4eeba --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_7.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/class_8.f03 b/gcc/testsuite/gfortran.dg/class_8.f03 new file mode 100644 index 0000000..78f10eb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_8.f03 @@ -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 |