diff options
Diffstat (limited to 'gcc/fortran/decl.c')
| -rw-r--r-- | gcc/fortran/decl.c | 121 |
1 files changed, 97 insertions, 24 deletions
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 82442042dcc..08d2bd69ddf 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1028,7 +1028,8 @@ verify_c_interop_param (gfc_symbol *sym) /* Build a polymorphic CLASS entity, using the symbol that comes from build_sym. A CLASS entity is represented by an encapsulating type, which contains the declared type as '$data' component, plus an integer component '$vindex' - which determines the dynamic type. */ + which determines the dynamic type, and another integer '$size', which + contains the size of the dynamic type structure. */ static gfc_try encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr, @@ -1077,6 +1078,7 @@ encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->attr.pointer = attr->pointer || attr->dummy; c->attr.allocatable = attr->allocatable; c->attr.dimension = attr->dimension; + c->attr.abstract = ts->u.derived->attr.abstract; c->as = (*as); c->initializer = gfc_get_expr (); c->initializer->expr_type = EXPR_NULL; @@ -1088,6 +1090,14 @@ encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->ts.kind = 4; c->attr.access = ACCESS_PRIVATE; c->initializer = gfc_int_expr (0); + + /* Add component '$size'. */ + if (gfc_add_component (fclass, "$size", &c) == FAILURE) + return FAILURE; + c->ts.type = BT_INTEGER; + c->ts.kind = 4; + c->attr.access = ACCESS_PRIVATE; + c->initializer = gfc_int_expr (0); } fclass->attr.extension = 1; @@ -1171,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; } @@ -1462,10 +1477,11 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, gfc_array_spec **as) { gfc_component *c; + gfc_try t = SUCCESS; - /* If the current symbol is of the same derived type that we're + /* F03:C438/C439. If the current symbol is of the same derived type that we're constructing, it must have the pointer attribute. */ - if (current_ts.type == BT_DERIVED + if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) && current_ts.u.derived == gfc_current_block () && current_attr.pointer == 0) { @@ -1544,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) { @@ -1557,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) @@ -1566,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 @@ -1575,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; } @@ -3751,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); @@ -3771,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) { @@ -5684,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) @@ -6746,8 +6783,44 @@ gfc_get_type_attr_spec (symbol_attribute *attr, char *name) } -/* Counter for assigning a unique vindex number to each derived type. */ -static int vindex_counter = 0; +/* Assign a hash value for a derived type. The algorithm is that of + SDBM. The hashed string is '[module_name #] derived_name'. */ +static unsigned int +hash_value (gfc_symbol *sym) +{ + unsigned int hash = 0; + const char *c; + int i, len; + + /* Hash of the module or procedure name. */ + if (sym->module != NULL) + c = sym->module; + else if (sym->ns && sym->ns->proc_name + && sym->ns->proc_name->attr.flavor == FL_MODULE) + c = sym->ns->proc_name->name; + else + c = NULL; + + if (c) + { + len = strlen (c); + for (i = 0; i < len; i++, c++) + hash = (hash << 6) + (hash << 16) - hash + (*c); + + /* Disambiguate between 'a' in 'aa' and 'aa' in 'a'. */ + hash = (hash << 6) + (hash << 16) - hash + '#'; + } + + /* Hash of the derived type name. */ + len = strlen (sym->name); + c = sym->name; + for (i = 0; i < len; i++, c++) + hash = (hash << 6) + (hash << 16) - hash + (*c); + + /* Return the hash but take the modulus for the sake of module read, + even though this slightly increases the chance of collision. */ + return (hash % 100000000); +} /* Match the beginning of a derived type declaration. If a type name @@ -6871,8 +6944,8 @@ gfc_match_derived_decl (void) } if (!sym->vindex) - /* Set the vindex for this type and increment the counter. */ - sym->vindex = ++vindex_counter; + /* Set the vindex for this type. */ + sym->vindex = hash_value (sym); /* Take over the ABSTRACT attribute. */ sym->attr.abstract = attr.abstract; |