From 2e23972ecbc374ca535d8fd40d18550e95bdd69d Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Sat, 17 Oct 2009 20:09:25 +0200 Subject: re PR fortran/41608 ([OOP] ICE with CLASS and invalid code) 2009-10-17 Janus Weil Paul Thomas 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 Paul Thomas 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 From-SVN: r152955 --- gcc/fortran/decl.c | 61 +++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 44 insertions(+), 17 deletions(-) (limited to 'gcc/fortran/decl.c') 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) -- cgit v1.1