diff options
Diffstat (limited to 'gcc/fortran')
-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 |
6 files changed, 76 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); |