diff options
Diffstat (limited to 'gcc')
26 files changed, 919 insertions, 337 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 03c1548..976061a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,74 @@ +2009-11-30 Janus Weil <janus@gcc.gnu.org> + + PR fortran/42053 + * resolve.c (resolve_select_type): Check for duplicate CLASS IS blocks. + +2009-11-30 Janus Weil <janus@gcc.gnu.org> + + PR fortran/41631 + * decl.c (gfc_match_derived_decl): Set extension level. + * gfortran.h (symbol_attribute): Expand 'extension' bit field to 8 bit. + * iresolve.c (gfc_resolve_extends_type_of): Return value of + 'is_extension_of' has kind=4. + * match.c (select_type_set_tmp,gfc_match_class_is): Create temporary + for CLASS IS blocks. + * module.c (MOD_VERSION): Bump module version. + (ab_attribute,attr_bits): Remove AB_EXTENSION. + (mio_symbol_attribute): Handle expanded 'extension' field. + * resolve.c (resolve_select_type): Implement CLASS IS blocks. + (resolve_fl_variable_derived): Show correct type name. + * symbol.c (gfc_build_class_symbol): Set extension level. + +2009-11-30 Janus Weil <janus@gcc.gnu.org> + + * intrinsic.h (gfc_resolve_extends_type_of): Add prototype. + * intrinsic.c (add_functions): Use 'gfc_resolve_extends_type_of'. + * iresolve.c (gfc_resolve_extends_type_of): New function, which + replaces the call to EXTENDS_TYPE_OF by the library function + 'is_extension_of' and modifies the arguments. + * trans-intrinsic.c (gfc_conv_extends_type_of): Removed. + (gfc_conv_intrinsic_function): FOR EXTENDS_TYPE_OF, don't call + gfc_conv_extends_type_of but gfc_conv_intrinsic_funcall. + +2009-11-30 Paul Thomas <pault@gcc.gnu.org> + Janus Weil <janus@gcc.gnu.org> + + * decl.c (encapsulate_class_symbol): Replaced by + 'gfc_build_class_symbol'. + (build_sym,build_struct): Call 'gfc_build_class_symbol'. + (gfc_match_derived_decl): Replace vindex by hash_value. + * dump-parse-tree.c (show_symbol): Replace vindex by hash_value. + * gfortran.h (symbol_attribute): Add field 'vtab'. + (gfc_symbol): Replace vindex by hash_value. + (gfc_class_esym_list): Ditto. + (gfc_get_derived_type,gfc_build_class_symbol,gfc_find_derived_vtab): + New prototypes. + * module.c (mio_symbol): Replace vindex by hash_value. + * resolve.c (vindex_expr): Rename to 'hash_value_expr'. + (resolve_class_compcall,resolve_class_typebound_call): Renamed + 'vindex_expr'. + (resolve_select_type): Replace $vindex by $vptr->$hash. + * symbol.c (gfc_add_save): Handle vtab symbols. + (gfc_type_compatible): Rewrite. + (gfc_build_class_symbol): New function which replaces + 'encapsulate_class_symbol'. + (gfc_find_derived_vtab): New function to set up a vtab symbol for a + derived type. + * trans-decl.c (gfc_create_module_variable): Handle vtab symbols. + * trans-expr.c (select_class_proc): Replace vindex by hash_value. + (gfc_conv_derived_to_class): New function to construct a temporary + CLASS variable from a derived type expression. + (gfc_conv_procedure_call): Call 'gfc_conv_derived_to_class'. + (gfc_conv_structure): Initialize the $extends and $size fields of + vtab symbols. + (gfc_trans_class_assign): Replace $vindex by $vptr. Remove the $size + assignment. + * trans-intrinsic.c (gfc_conv_same_type_as): Replace $vindex by + $vptr->$hash, and replace vindex by hash_value. + * trans-stmt.c (gfc_trans_allocate): Insert $vptr references, replace + $vindex by $vptr. Remove the $size assignment. + * trans-types.c (gfc_get_derived_type): Make it non-static. + 2009-11-30 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/42131 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 23ac5c3..90f30b3 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1025,88 +1025,6 @@ 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, 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, - gfc_array_spec **as) -{ - char name[GFC_MAX_SYMBOL_LEN + 5]; - gfc_symbol *fclass; - gfc_component *c; - - /* Determine the name of the encapsulating type. */ - if ((*as) && (*as)->rank && attr->allocatable) - sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank); - else if ((*as) && (*as)->rank) - sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank); - else if (attr->allocatable) - sprintf (name, ".class.%s.a", ts->u.derived->name); - else - sprintf (name, ".class.%s", ts->u.derived->name); - - gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass); - if (fclass == NULL) - { - gfc_symtree *st; - /* If not there, create a new symbol. */ - fclass = gfc_new_symbol (name, ts->u.derived->ns); - st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name); - st->n.sym = fclass; - gfc_set_sym_referenced (fclass); - fclass->refs++; - fclass->ts.type = BT_UNKNOWN; - fclass->vindex = ts->u.derived->vindex; - fclass->attr.abstract = ts->u.derived->attr.abstract; - if (ts->u.derived->f2k_derived) - fclass->f2k_derived = gfc_get_namespace (NULL, 0); - if (gfc_add_flavor (&fclass->attr, FL_DERIVED, - NULL, &gfc_current_locus) == FAILURE) - return FAILURE; - - /* Add component '$data'. */ - if (gfc_add_component (fclass, "$data", &c) == FAILURE) - return FAILURE; - c->ts = *ts; - c->ts.type = BT_DERIVED; - c->attr.access = ACCESS_PRIVATE; - c->ts.u.derived = ts->u.derived; - 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; - - /* Add component '$vindex'. */ - if (gfc_add_component (fclass, "$vindex", &c) == FAILURE) - return FAILURE; - c->ts.type = BT_INTEGER; - 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; - fclass->attr.is_class = 1; - ts->u.derived = fclass; - attr->allocatable = attr->pointer = attr->dimension = 0; - (*as) = NULL; /* XXX */ - return SUCCESS; -} /* Function called by variable_decl() that adds a name to the symbol table. */ @@ -1185,7 +1103,7 @@ build_sym (const char *name, gfc_charlen *cl, sym->attr.class_ok = (sym->attr.dummy || sym->attr.pointer || sym->attr.allocatable) ? 1 : 0; - encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as); + gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as); } return SUCCESS; @@ -1594,7 +1512,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, scalar: if (c->ts.type == BT_CLASS) - encapsulate_class_symbol (&c->ts, &c->attr, &c->as); + gfc_build_class_symbol (&c->ts, &c->attr, &c->as); return t; } @@ -6926,13 +6844,23 @@ gfc_match_derived_decl (void) /* Add the extended derived type as the first component. */ gfc_add_component (sym, parent, &p); - sym->attr.extension = attr.extension; extended->refs++; gfc_set_sym_referenced (extended); p->ts.type = BT_DERIVED; p->ts.u.derived = extended; p->initializer = gfc_default_initializer (&p->ts); + + /* Set extension level. */ + if (extended->attr.extension == 255) + { + /* Since the extension field is 8 bit wide, we can only have + up to 255 extension levels. */ + gfc_error ("Maximum extension level reached with type '%s' at %L", + extended->name, &extended->declared_at); + return MATCH_ERROR; + } + sym->attr.extension = extended->attr.extension + 1; /* Provide the links between the extended type and its extension. */ if (!extended->f2k_derived) @@ -6941,9 +6869,9 @@ gfc_match_derived_decl (void) st->n.sym = sym; } - if (!sym->vindex) - /* Set the vindex for this type. */ - sym->vindex = hash_value (sym); + if (!sym->hash_value) + /* Set the hash for the compound name for this type. */ + sym->hash_value = hash_value (sym); /* Take over the ABSTRACT attribute. */ sym->attr.abstract = attr.abstract; diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 32ff298..97289c2 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -827,8 +827,8 @@ show_symbol (gfc_symbol *sym) if (sym->f2k_derived) { show_indent (); - if (sym->vindex) - fprintf (dumpfile, "vindex: %d", sym->vindex); + if (sym->hash_value) + fprintf (dumpfile, "hash: %d", sym->hash_value); show_f2k_derived (sym->f2k_derived); } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index cc3ccf5..e552203 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -670,9 +670,10 @@ typedef struct unsigned untyped:1; /* No implicit type could be found. */ unsigned is_bind_c:1; /* say if is bound to C. */ - unsigned extension:1; /* extends a derived type. */ + unsigned extension:8; /* extension level of a derived type. */ unsigned is_class:1; /* is a CLASS container. */ unsigned class_ok:1; /* is a CLASS object with correct attributes. */ + unsigned vtab:1; /* is a derived type vtab. */ /* These flags are both in the typespec and attribute. The attribute list is what gets read from/written to a module file. The typespec @@ -1137,8 +1138,8 @@ typedef struct gfc_symbol int entry_id; /* Used in resolve.c for entries. */ - /* CLASS vindex for declared and dynamic types in the class. */ - int vindex; + /* CLASS hashed name for declared and dynamic types in the class. */ + int hash_value; struct gfc_symbol *common_next; /* Links for COMMON syms */ @@ -1599,7 +1600,7 @@ typedef struct gfc_class_esym_list { gfc_symbol *derived; gfc_symbol *esym; - struct gfc_expr *vindex; + struct gfc_expr *hash_value; struct gfc_class_esym_list *next; } gfc_class_esym_list; @@ -2380,6 +2381,7 @@ gfc_try gfc_check_any_c_kind (gfc_typespec *); int gfc_validate_kind (bt, int, bool); int gfc_get_int_kind_from_width_isofortranenv (int size); int gfc_get_real_kind_from_width_isofortranenv (int size); +tree gfc_get_derived_type (gfc_symbol * derived); extern int gfc_index_integer_kind; extern int gfc_default_integer_kind; extern int gfc_max_integer_kind; @@ -2517,6 +2519,9 @@ void gfc_free_dt_list (void); gfc_gsymbol *gfc_get_gsymbol (const char *); gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *); +gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *, + gfc_array_spec **); +gfc_symbol *gfc_find_derived_vtab (gfc_symbol *); gfc_typebound_proc* gfc_get_typebound_proc (void); gfc_symbol* gfc_get_derived_super_type (gfc_symbol*); gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*); diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index a62dd92..859fd4b 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1601,7 +1601,7 @@ add_functions (void) add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003, - gfc_check_same_type_as, NULL, NULL, + gfc_check_same_type_as, NULL, gfc_resolve_extends_type_of, a, BT_UNKNOWN, 0, REQUIRED, mo, BT_UNKNOWN, 0, REQUIRED); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index acd3f78..cf436db 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -390,6 +390,7 @@ void gfc_resolve_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, void gfc_resolve_etime_sub (gfc_code *); void gfc_resolve_exp (gfc_expr *, gfc_expr *); void gfc_resolve_exponent (gfc_expr *, gfc_expr *); +void gfc_resolve_extends_type_of (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_fdate (gfc_expr *); void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_fnum (gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 960be08..7e8bdfb 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -806,6 +806,57 @@ gfc_resolve_exponent (gfc_expr *f, gfc_expr *x) } +/* Resolve the EXTENDS_TYPE_OF intrinsic function. */ + +void +gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo) +{ + gfc_symbol *vtab; + gfc_symtree *st; + + /* Prevent double resolution. */ + if (f->ts.type == BT_LOGICAL) + return; + + /* Replace the first argument with the corresponding vtab. */ + if (a->ts.type == BT_CLASS) + gfc_add_component_ref (a, "$vptr"); + else if (a->ts.type == BT_DERIVED) + { + vtab = gfc_find_derived_vtab (a->ts.u.derived); + /* Clear the old expr. */ + gfc_free_ref_list (a->ref); + memset (a, '\0', sizeof (gfc_expr)); + /* Construct a new one. */ + a->expr_type = EXPR_VARIABLE; + st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); + a->symtree = st; + a->ts = vtab->ts; + } + + /* Replace the second argument with the corresponding vtab. */ + if (mo->ts.type == BT_CLASS) + gfc_add_component_ref (mo, "$vptr"); + else if (mo->ts.type == BT_DERIVED) + { + vtab = gfc_find_derived_vtab (mo->ts.u.derived); + /* Clear the old expr. */ + gfc_free_ref_list (mo->ref); + memset (mo, '\0', sizeof (gfc_expr)); + /* Construct a new one. */ + mo->expr_type = EXPR_VARIABLE; + st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); + mo->symtree = st; + mo->ts = vtab->ts; + } + + f->ts.type = BT_LOGICAL; + f->ts.kind = 4; + /* Call library function. */ + f->value.function.name = gfc_get_string (PREFIX ("is_extension_of")); +} + + void gfc_resolve_fdate (gfc_expr *f) { diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 153dfdb3..9e76818 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -3968,13 +3968,25 @@ select_type_set_tmp (gfc_typespec *ts) { char name[GFC_MAX_SYMBOL_LEN]; gfc_symtree *tmp; + + if (!gfc_type_is_extensible (ts->u.derived)) + return; - sprintf (name, "tmp$%s", ts->u.derived->name); + if (ts->type == BT_CLASS) + sprintf (name, "tmp$class$%s", ts->u.derived->name); + else + sprintf (name, "tmp$type$%s", ts->u.derived->name); gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); gfc_add_type (tmp->n.sym, ts, NULL); gfc_set_sym_referenced (tmp->n.sym); gfc_add_pointer (&tmp->n.sym->attr, NULL); gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); + if (ts->type == BT_CLASS) + { + gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, + &tmp->n.sym->as); + tmp->n.sym->attr.class_ok = 1; + } select_type_stack->tmp = tmp; } @@ -4228,8 +4240,9 @@ gfc_match_class_is (void) new_st.op = EXEC_SELECT_TYPE; new_st.ext.case_list = c; - - gfc_error_now ("CLASS IS specification at %C is not yet supported"); + + /* Create temporary variable. */ + select_type_set_tmp (&c->ts); return MATCH_YES; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 36095a2..d732b66 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -77,7 +77,7 @@ along with GCC; see the file COPYING3. If not see /* Don't put any single quote (') in MOD_VERSION, if yout want it to be recognized. */ -#define MOD_VERSION "3" +#define MOD_VERSION "4" /* Structure that describes a position within a module file. */ @@ -1671,7 +1671,7 @@ typedef enum AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP, AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP, - AB_EXTENSION, AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER + AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER } ab_attribute; @@ -1711,7 +1711,6 @@ static const mstring attr_bits[] = minit ("ZERO_COMP", AB_ZERO_COMP), minit ("PROTECTED", AB_PROTECTED), minit ("ABSTRACT", AB_ABSTRACT), - minit ("EXTENSION", AB_EXTENSION), minit ("IS_CLASS", AB_IS_CLASS), minit ("PROCEDURE", AB_PROCEDURE), minit ("PROC_POINTER", AB_PROC_POINTER), @@ -1771,7 +1770,7 @@ static void mio_symbol_attribute (symbol_attribute *attr) { atom_type t; - unsigned ext_attr; + unsigned ext_attr,extension_level; mio_lparen (); @@ -1780,10 +1779,15 @@ mio_symbol_attribute (symbol_attribute *attr) attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures); attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types); attr->save = MIO_NAME (save_state) (attr->save, save_status); + ext_attr = attr->ext_attr; mio_integer ((int *) &ext_attr); attr->ext_attr = ext_attr; + extension_level = attr->extension; + mio_integer ((int *) &extension_level); + attr->extension = extension_level; + if (iomode == IO_OUTPUT) { if (attr->allocatable) @@ -1858,8 +1862,6 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits); if (attr->zero_comp) MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits); - if (attr->extension) - MIO_NAME (ab_attribute) (AB_EXTENSION, attr_bits); if (attr->is_class) MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits); if (attr->procedure) @@ -1984,9 +1986,6 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_ZERO_COMP: attr->zero_comp = 1; break; - case AB_EXTENSION: - attr->extension = 1; - break; case AB_IS_CLASS: attr->is_class = 1; break; @@ -3574,7 +3573,7 @@ mio_symbol (gfc_symbol *sym) mio_integer (&(sym->intmod_sym_id)); if (sym->attr.flavor == FL_DERIVED) - mio_integer (&(sym->vindex)); + mio_integer (&(sym->hash_value)); mio_rparen (); } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index b685312..bf705c6 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5218,41 +5218,35 @@ resolve_class_esym (gfc_expr *e) } -/* Generate an expression for the vindex, given the reference to +/* Generate an expression for the hash value, given the reference to the class of the final expression (class_ref), the base of the full reference list (new_ref), the declared type and the class object (st). */ static gfc_expr* -vindex_expr (gfc_ref *class_ref, gfc_ref *new_ref, - gfc_symbol *declared, gfc_symtree *st) +hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st) { - gfc_expr *vindex; - gfc_ref *ref; + gfc_expr *hash_value; - /* Build an expression for the correct vindex; ie. that of the last + /* Build an expression for the correct hash_value; ie. that of the last CLASS reference. */ - ref = gfc_get_ref(); - ref->type = REF_COMPONENT; - ref->u.c.component = declared->components->next; - ref->u.c.sym = declared; - ref->next = NULL; if (class_ref) { - class_ref->next = ref; + class_ref->next = NULL; } else { gfc_free_ref_list (new_ref); - new_ref = ref; + new_ref = NULL; } - vindex = gfc_get_expr (); - vindex->expr_type = EXPR_VARIABLE; - vindex->symtree = st; - vindex->symtree->n.sym->refs++; - vindex->ts = ref->u.c.component->ts; - vindex->ref = new_ref; + hash_value = gfc_get_expr (); + hash_value->expr_type = EXPR_VARIABLE; + hash_value->symtree = st; + hash_value->symtree->n.sym->refs++; + hash_value->ref = new_ref; + gfc_add_component_ref (hash_value, "$vptr"); + gfc_add_component_ref (hash_value, "$hash"); - return vindex; + return hash_value; } @@ -5352,10 +5346,10 @@ resolve_class_compcall (gfc_expr* e) resolve_class_esym (e); /* More than one typebound procedure so transmit an expression for - the vindex as the selector. */ + the hash_value as the selector. */ if (e->value.function.class_esym != NULL) - e->value.function.class_esym->vindex - = vindex_expr (class_ref, new_ref, declared, st); + e->value.function.class_esym->hash_value + = hash_value_expr (class_ref, new_ref, st); return class_try; } @@ -5407,10 +5401,10 @@ resolve_class_typebound_call (gfc_code *code) resolve_class_esym (code->expr1); /* More than one typebound procedure so transmit an expression for - the vindex as the selector. */ + the hash_value as the selector. */ if (code->expr1->value.function.class_esym != NULL) - code->expr1->value.function.class_esym->vindex - = vindex_expr (class_ref, new_ref, declared, st); + code->expr1->value.function.class_esym->hash_value + = hash_value_expr (class_ref, new_ref, st); return class_try; } @@ -6862,11 +6856,13 @@ static void resolve_select_type (gfc_code *code) { gfc_symbol *selector_type; - gfc_code *body, *new_st; - gfc_case *c, *default_case; + gfc_code *body, *new_st, *if_st, *tail; + gfc_code *class_is = NULL, *default_case = NULL; + gfc_case *c; gfc_symtree *st; char name[GFC_MAX_SYMBOL_LEN]; gfc_namespace *ns; + int error = 0; ns = code->ext.ns; gfc_resolve (ns); @@ -6876,9 +6872,6 @@ resolve_select_type (gfc_code *code) else selector_type = code->expr1->ts.u.derived->components->ts.u.derived; - /* Assume there is no DEFAULT case. */ - default_case = NULL; - /* Loop over TYPE IS / CLASS IS cases. */ for (body = code->block; body; body = body->block) { @@ -6890,6 +6883,7 @@ resolve_select_type (gfc_code *code) { gfc_error ("Derived type '%s' at %L must be extensible", c->ts.u.derived->name, &c->where); + error++; continue; } @@ -6899,6 +6893,7 @@ resolve_select_type (gfc_code *code) { gfc_error ("Derived type '%s' at %L must be an extension of '%s'", c->ts.u.derived->name, &c->where, selector_type->name); + error++; continue; } @@ -6906,15 +6901,21 @@ resolve_select_type (gfc_code *code) if (c->ts.type == BT_UNKNOWN) { /* Check F03:C818. */ - if (default_case != NULL) - gfc_error ("The DEFAULT CASE at %L cannot be followed " - "by a second DEFAULT CASE at %L", - &default_case->where, &c->where); + if (default_case) + { + gfc_error ("The DEFAULT CASE at %L cannot be followed " + "by a second DEFAULT CASE at %L", + &default_case->ext.case_list->where, &c->where); + error++; + continue; + } else - default_case = c; - continue; + default_case = body; } } + + if (error>0) + return; if (code->expr2) { @@ -6944,45 +6945,153 @@ resolve_select_type (gfc_code *code) /* Transform to EXEC_SELECT. */ code->op = EXEC_SELECT; - gfc_add_component_ref (code->expr1, "$vindex"); + gfc_add_component_ref (code->expr1, "$vptr"); + gfc_add_component_ref (code->expr1, "$hash"); /* Loop over TYPE IS / CLASS IS cases. */ for (body = code->block; body; body = body->block) { c = body->ext.case_list; + if (c->ts.type == BT_DERIVED) - c->low = c->high = gfc_int_expr (c->ts.u.derived->vindex); - else if (c->ts.type == BT_CLASS) - /* Currently IS CLASS blocks are simply ignored. - TODO: Implement IS CLASS. */ - c->unreachable = 1; - - if (c->ts.type != BT_DERIVED) + c->low = c->high = gfc_int_expr (c->ts.u.derived->hash_value); + else if (c->ts.type == BT_UNKNOWN) continue; + /* Assign temporary to selector. */ - sprintf (name, "tmp$%s", c->ts.u.derived->name); + if (c->ts.type == BT_CLASS) + sprintf (name, "tmp$class$%s", c->ts.u.derived->name); + else + sprintf (name, "tmp$type$%s", c->ts.u.derived->name); st = gfc_find_symtree (ns->sym_root, name); new_st = gfc_get_code (); - new_st->op = EXEC_POINTER_ASSIGN; new_st->expr1 = gfc_get_variable_expr (st); new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree); - gfc_add_component_ref (new_st->expr2, "$data"); + if (c->ts.type == BT_DERIVED) + { + new_st->op = EXEC_POINTER_ASSIGN; + gfc_add_component_ref (new_st->expr2, "$data"); + } + else + new_st->op = EXEC_POINTER_ASSIGN; new_st->next = body->next; body->next = new_st; } + + /* Take out CLASS IS cases for separate treatment. */ + body = code; + while (body && body->block) + { + if (body->block->ext.case_list->ts.type == BT_CLASS) + { + /* Add to class_is list. */ + if (class_is == NULL) + { + class_is = body->block; + tail = class_is; + } + else + { + for (tail = class_is; tail->block; tail = tail->block) ; + tail->block = body->block; + tail = tail->block; + } + /* Remove from EXEC_SELECT list. */ + body->block = body->block->block; + tail->block = NULL; + } + else + body = body->block; + } - /* Eliminate dead blocks. */ - for (body = code; body && body->block; body = body->block) + if (class_is) { - if (body->block->ext.case_list->unreachable) + gfc_symbol *vtab; + + if (!default_case) + { + /* Add a default case to hold the CLASS IS cases. */ + for (tail = code; tail->block; tail = tail->block) ; + tail->block = gfc_get_code (); + tail = tail->block; + tail->op = EXEC_SELECT_TYPE; + tail->ext.case_list = gfc_get_case (); + tail->ext.case_list->ts.type = BT_UNKNOWN; + tail->next = NULL; + default_case = tail; + } + + /* More than one CLASS IS block? */ + if (class_is->block) { - /* Cut the unreachable block from the code chain. */ - gfc_code *cd = body->block; - body->block = cd->block; - /* Kill the dead block, but not the blocks below it. */ - cd->block = NULL; - gfc_free_statements (cd); + gfc_code **c1,*c2; + bool swapped; + /* Sort CLASS IS blocks by extension level. */ + do + { + swapped = false; + for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block)) + { + c2 = (*c1)->block; + /* F03:C817 (check for doubles). */ + if ((*c1)->ext.case_list->ts.u.derived->hash_value + == c2->ext.case_list->ts.u.derived->hash_value) + { + gfc_error ("Double CLASS IS block in SELECT TYPE " + "statement at %L", &c2->ext.case_list->where); + return; + } + if ((*c1)->ext.case_list->ts.u.derived->attr.extension + < c2->ext.case_list->ts.u.derived->attr.extension) + { + /* Swap. */ + (*c1)->block = c2->block; + c2->block = *c1; + *c1 = c2; + swapped = true; + } + } + } + while (swapped); } + + /* Generate IF chain. */ + if_st = gfc_get_code (); + if_st->op = EXEC_IF; + new_st = if_st; + for (body = class_is; body; body = body->block) + { + new_st->block = gfc_get_code (); + new_st = new_st->block; + new_st->op = EXEC_IF; + /* Set up IF condition: Call _gfortran_is_extension_of. */ + new_st->expr1 = gfc_get_expr (); + new_st->expr1->expr_type = EXPR_FUNCTION; + new_st->expr1->ts.type = BT_LOGICAL; + new_st->expr1->ts.kind = 4; + new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of")); + new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym); + new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF; + /* Set up arguments. */ + new_st->expr1->value.function.actual = gfc_get_actual_arglist (); + new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree); + gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr"); + vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived); + st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); + new_st->expr1->value.function.actual->next = gfc_get_actual_arglist (); + new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st); + new_st->next = body->next; + } + if (default_case->next) + { + new_st->block = gfc_get_code (); + new_st = new_st->block; + new_st->op = EXEC_IF; + new_st->next = default_case->next; + } + + /* Replace CLASS DEFAULT code by the IF chain. */ + default_case->next = if_st; } resolve_select (code); @@ -8751,7 +8860,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived)) { gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", - sym->ts.u.derived->name, sym->name, &sym->declared_at); + sym->ts.u.derived->components->ts.u.derived->name, + sym->name, &sym->declared_at); return FAILURE; } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index c1b39b0..6dd0a8a 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1045,7 +1045,7 @@ gfc_add_save (symbol_attribute *attr, const char *name, locus *where) return FAILURE; } - if (attr->save == SAVE_EXPLICIT) + if (attr->save == SAVE_EXPLICIT && !attr->vtab) { if (gfc_notify_std (GFC_STD_LEGACY, "Duplicate SAVE attribute specified at %L", @@ -4592,22 +4592,228 @@ gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2) bool gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) { - if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS) - && (ts2->type == BT_DERIVED || ts2->type == BT_CLASS)) + gfc_component *cmp1, *cmp2; + + bool is_class1 = (ts1->type == BT_CLASS); + bool is_class2 = (ts2->type == BT_CLASS); + bool is_derived1 = (ts1->type == BT_DERIVED); + bool is_derived2 = (ts2->type == BT_DERIVED); + + if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2) + return (ts1->type == ts2->type); + + if (is_derived1 && is_derived2) + return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); + + cmp1 = cmp2 = NULL; + + if (is_class1) { - if (ts1->type == BT_CLASS && ts2->type == BT_DERIVED) - return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, - ts2->u.derived); - else if (ts1->type == BT_CLASS && ts2->type == BT_CLASS) - return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, - ts2->u.derived->components->ts.u.derived); - else if (ts2->type != BT_CLASS) - return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); - else + cmp1 = gfc_find_component (ts1->u.derived, "$data", true, false); + if (cmp1 == NULL) return 0; } + + if (is_class2) + { + cmp2 = gfc_find_component (ts2->u.derived, "$data", true, false); + if (cmp2 == NULL) + return 0; + } + + if (is_class1 && is_derived2) + return gfc_type_is_extension_of (cmp1->ts.u.derived, ts2->u.derived); + + else if (is_class1 && is_class2) + return gfc_type_is_extension_of (cmp1->ts.u.derived, cmp2->ts.u.derived); + else - return (ts1->type == ts2->type); + return 0; +} + + +/* 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 a pointer + component '$vptr' which determines the dynamic type. */ + +gfc_try +gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, + gfc_array_spec **as) +{ + char name[GFC_MAX_SYMBOL_LEN + 5]; + gfc_symbol *fclass; + gfc_symbol *vtab; + gfc_component *c; + + /* Determine the name of the encapsulating type. */ + if ((*as) && (*as)->rank && attr->allocatable) + sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank); + else if ((*as) && (*as)->rank) + sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank); + else if (attr->allocatable) + sprintf (name, ".class.%s.a", ts->u.derived->name); + else + sprintf (name, ".class.%s", ts->u.derived->name); + + gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass); + if (fclass == NULL) + { + gfc_symtree *st; + /* If not there, create a new symbol. */ + fclass = gfc_new_symbol (name, ts->u.derived->ns); + st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name); + st->n.sym = fclass; + gfc_set_sym_referenced (fclass); + fclass->refs++; + fclass->ts.type = BT_UNKNOWN; + fclass->attr.abstract = ts->u.derived->attr.abstract; + if (ts->u.derived->f2k_derived) + fclass->f2k_derived = gfc_get_namespace (NULL, 0); + if (gfc_add_flavor (&fclass->attr, FL_DERIVED, + NULL, &gfc_current_locus) == FAILURE) + return FAILURE; + + /* Add component '$data'. */ + if (gfc_add_component (fclass, "$data", &c) == FAILURE) + return FAILURE; + c->ts = *ts; + c->ts.type = BT_DERIVED; + c->attr.access = ACCESS_PRIVATE; + c->ts.u.derived = ts->u.derived; + 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; + + /* Add component '$vptr'. */ + if (gfc_add_component (fclass, "$vptr", &c) == FAILURE) + return FAILURE; + c->ts.type = BT_DERIVED; + vtab = gfc_find_derived_vtab (ts->u.derived); + gcc_assert (vtab); + c->ts.u.derived = vtab->ts.u.derived; + c->attr.pointer = 1; + c->initializer = gfc_get_expr (); + c->initializer->expr_type = EXPR_NULL; + } + + /* Since the extension field is 8 bit wide, we can only have + up to 255 extension levels. */ + if (ts->u.derived->attr.extension == 255) + { + gfc_error ("Maximum extension level reached with type '%s' at %L", + ts->u.derived->name, &ts->u.derived->declared_at); + return FAILURE; + } + + fclass->attr.extension = ts->u.derived->attr.extension + 1; + fclass->attr.is_class = 1; + ts->u.derived = fclass; + attr->allocatable = attr->pointer = attr->dimension = 0; + (*as) = NULL; /* XXX */ + return SUCCESS; +} + + +/* Find the symbol for a derived type's vtab. */ + +gfc_symbol * +gfc_find_derived_vtab (gfc_symbol *derived) +{ + gfc_namespace *ns; + gfc_symbol *vtab = NULL, *vtype = NULL; + char name[2 * GFC_MAX_SYMBOL_LEN + 8]; + + ns = gfc_current_ns; + + for (; ns; ns = ns->parent) + if (!ns->parent) + break; + + if (ns) + { + sprintf (name, "vtab$%s", derived->name); + gfc_find_symbol (name, ns, 0, &vtab); + + if (vtab == NULL) + { + gfc_get_symbol (name, ns, &vtab); + vtab->ts.type = BT_DERIVED; + vtab->attr.flavor = FL_VARIABLE; + vtab->attr.target = 1; + vtab->attr.save = SAVE_EXPLICIT; + vtab->attr.vtab = 1; + vtab->refs++; + gfc_set_sym_referenced (vtab); + sprintf (name, "vtype$%s", derived->name); + + gfc_find_symbol (name, ns, 0, &vtype); + if (vtype == NULL) + { + gfc_component *c; + gfc_symbol *parent = NULL, *parent_vtab = NULL; + + gfc_get_symbol (name, ns, &vtype); + if (gfc_add_flavor (&vtype->attr, FL_DERIVED, + NULL, &gfc_current_locus) == FAILURE) + return NULL; + vtype->refs++; + gfc_set_sym_referenced (vtype); + + /* Add component '$hash'. */ + if (gfc_add_component (vtype, "$hash", &c) == FAILURE) + return NULL; + c->ts.type = BT_INTEGER; + c->ts.kind = 4; + c->attr.access = ACCESS_PRIVATE; + c->initializer = gfc_int_expr (derived->hash_value); + + /* Add component '$size'. */ + if (gfc_add_component (vtype, "$size", &c) == FAILURE) + return NULL; + c->ts.type = BT_INTEGER; + c->ts.kind = 4; + c->attr.access = ACCESS_PRIVATE; + /* Remember the derived type in ts.u.derived, + so that the correct initializer can be set later on + (in gfc_conv_structure). */ + c->ts.u.derived = derived; + c->initializer = gfc_int_expr (0); + + /* Add component $extends. */ + if (gfc_add_component (vtype, "$extends", &c) == FAILURE) + return NULL; + c->attr.pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->initializer = gfc_get_expr (); + parent = gfc_get_derived_super_type (derived); + if (parent) + { + parent_vtab = gfc_find_derived_vtab (parent); + c->ts.type = BT_DERIVED; + c->ts.u.derived = parent_vtab->ts.u.derived; + c->initializer->expr_type = EXPR_VARIABLE; + gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0, + &c->initializer->symtree); + } + else + { + c->ts.type = BT_DERIVED; + c->ts.u.derived = vtype; + c->initializer->expr_type = EXPR_NULL; + } + } + vtab->ts.u.derived = vtype; + + vtab->value = gfc_default_initializer (&vtab->ts); + } + } + + return vtab; } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 200c3f5..2e3fedd 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3405,7 +3405,7 @@ gfc_create_module_variable (gfc_symbol * sym) && (sym->equiv_built || sym->attr.in_equivalence)) return; - if (sym->backend_decl) + if (sym->backend_decl && !sym->attr.vtab) internal_error ("backend decl for module variable %s already exists", sym->name); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 77de6bd..acca306 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1530,16 +1530,16 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, tree end_label; tree label; tree tmp; - tree vindex; + tree hash; stmtblock_t body; gfc_class_esym_list *next_elist, *tmp_elist; gfc_se tmpse; - /* Convert the vindex expression. */ + /* Convert the hash expression. */ gfc_init_se (&tmpse, NULL); - gfc_conv_expr (&tmpse, elist->vindex); + gfc_conv_expr (&tmpse, elist->hash_value); gfc_add_block_to_block (&se->pre, &tmpse.pre); - vindex = gfc_evaluate_now (tmpse.expr, &se->pre); + hash = gfc_evaluate_now (tmpse.expr, &se->pre); gfc_add_block_to_block (&se->post, &tmpse.post); /* Fix the function type to be that of the declared type method. */ @@ -1566,9 +1566,9 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, if (elist->esym != tmp_elist->esym) continue; - cval = build_int_cst (TREE_TYPE (vindex), - elist->derived->vindex); - /* Build a label for the vindex value. */ + cval = build_int_cst (TREE_TYPE (hash), + elist->derived->hash_value); + /* Build a label for the hash value. */ label = gfc_build_label_decl (NULL_TREE); tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, cval, NULL_TREE, label); @@ -1601,8 +1601,8 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, segfaults because it occurs too early and too often. */ free_elist: next_elist = elist->next; - if (elist->vindex) - gfc_free_expr (elist->vindex); + if (elist->hash_value) + gfc_free_expr (elist->hash_value); gfc_free (elist); elist = NULL; } @@ -1613,12 +1613,12 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, NULL_TREE, NULL_TREE, label); gfc_add_expr_to_block (&body, tmp); tmp = gfc_trans_runtime_error (true, &expr->where, - "internal error: bad vindex in dynamic dispatch"); + "internal error: bad hash value in dynamic dispatch"); gfc_add_expr_to_block (&body, tmp); /* Write the switch expression. */ tmp = gfc_finish_block (&body); - tmp = build3_v (SWITCH_EXPR, vindex, tmp, NULL_TREE); + tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE); gfc_add_expr_to_block (&se->pre, tmp); tmp = build1_v (LABEL_EXPR, end_label); @@ -2531,6 +2531,60 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name) } +/* Takes a derived type expression and returns the address of a temporary + class object of the 'declared' type. */ +static void +gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, + gfc_typespec class_ts) +{ + gfc_component *cmp; + gfc_symbol *vtab; + gfc_symbol *declared = class_ts.u.derived; + gfc_ss *ss; + tree ctree; + tree var; + tree tmp; + + /* The derived type needs to be converted to a temporary + CLASS object. */ + tmp = gfc_typenode_for_spec (&class_ts); + var = gfc_create_var (tmp, "class"); + + /* Set the vptr. */ + cmp = gfc_find_component (declared, "$vptr", true, true); + ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), + var, cmp->backend_decl, NULL_TREE); + + /* Remember the vtab corresponds to the derived type + not to the class declared type. */ + vtab = gfc_find_derived_vtab (e->ts.u.derived); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify (&parmse->pre, ctree, + fold_convert (TREE_TYPE (ctree), tmp)); + + /* Now set the data field. */ + cmp = gfc_find_component (declared, "$data", true, true); + ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), + var, cmp->backend_decl, NULL_TREE); + ss = gfc_walk_expr (e); + if (ss == gfc_ss_terminator) + { + gfc_conv_expr_reference (parmse, e); + tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); + gfc_add_modify (&parmse->pre, ctree, tmp); + } + else + { + gfc_conv_expr (parmse, e); + gfc_add_modify (&parmse->pre, ctree, parmse->expr); + } + + /* Pass the address of the class object. */ + parmse->expr = gfc_build_addr_expr (NULL_TREE, var); +} + + /* The following routine generates code for the intrinsic procedures from the ISO_C_BINDING module: * C_LOC (function) @@ -2800,53 +2854,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_DERIVED) { - tree data; - tree vindex; - tree size; - /* The derived type needs to be converted to a temporary CLASS object. */ gfc_init_se (&parmse, se); - type = gfc_typenode_for_spec (&fsym->ts); - var = gfc_create_var (type, "class"); - - /* Get the components. */ - tmp = fsym->ts.u.derived->components->backend_decl; - data = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), - var, tmp, NULL_TREE); - tmp = fsym->ts.u.derived->components->next->backend_decl; - vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), - var, tmp, NULL_TREE); - tmp = fsym->ts.u.derived->components->next->next->backend_decl; - size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), - var, tmp, NULL_TREE); - - /* Set the vindex. */ - tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex); - gfc_add_modify (&parmse.pre, vindex, tmp); - - /* Set the size. */ - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts)); - gfc_add_modify (&parmse.pre, size, - fold_convert (TREE_TYPE (size), tmp)); - - /* Now set the data field. */ - argss = gfc_walk_expr (e); - if (argss == gfc_ss_terminator) - { - gfc_conv_expr_reference (&parmse, e); - tmp = fold_convert (TREE_TYPE (data), - parmse.expr); - gfc_add_modify (&parmse.pre, data, tmp); - } - else - { - gfc_conv_expr (&parmse, e); - gfc_add_modify (&parmse.pre, data, parmse.expr); - } - - /* Pass the address of the class object. */ - parmse.expr = gfc_build_addr_expr (NULL_TREE, var); + gfc_conv_derived_to_class (&parmse, e, fsym->ts); } else if (se->ss && se->ss->useflags) { @@ -4240,14 +4251,27 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) if (cm->ts.type == BT_CLASS) { + gfc_component *data; + data = gfc_find_component (cm->ts.u.derived, "$data", true, true); val = gfc_conv_initializer (c->expr, &cm->ts, - TREE_TYPE (cm->ts.u.derived->components->backend_decl), - cm->ts.u.derived->components->attr.dimension, - cm->ts.u.derived->components->attr.pointer); + TREE_TYPE (data->backend_decl), + data->attr.dimension, + data->attr.pointer); - /* Append it to the constructor list. */ - CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl, - val); + CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val); + } + else if (strcmp (cm->name, "$size") == 0) + { + val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived)); + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + } + else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL + && strcmp (cm->name, "$extends") == 0) + { + gfc_symbol *vtabs; + vtabs = cm->initializer->symtree->n.sym; + val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs)); + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); } else { @@ -5366,47 +5390,37 @@ gfc_trans_class_assign (gfc_code *code) { stmtblock_t block; tree tmp; + gfc_expr *lhs; + gfc_expr *rhs; gfc_start_block (&block); if (code->expr2->ts.type != BT_CLASS) { - /* Insert an additional assignment which sets the '$vindex' field. */ - gfc_expr *lhs,*rhs; + /* Insert an additional assignment which sets the '$vptr' field. */ lhs = gfc_copy_expr (code->expr1); - gfc_add_component_ref (lhs, "$vindex"); - if (code->expr2->ts.type == BT_DERIVED) - /* vindex is constant, determined at compile time. */ - rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex); - else if (code->expr2->expr_type == EXPR_NULL) - rhs = gfc_int_expr (0); - else - gcc_unreachable (); - tmp = gfc_trans_assignment (lhs, rhs, false); - gfc_add_expr_to_block (&block, tmp); - - /* Insert another assignment which sets the '$size' field. */ - lhs = gfc_copy_expr (code->expr1); - gfc_add_component_ref (lhs, "$size"); + gfc_add_component_ref (lhs, "$vptr"); if (code->expr2->ts.type == BT_DERIVED) { - /* Size is fixed at compile time. */ - gfc_se lse; - gfc_init_se (&lse, NULL); - gfc_conv_expr (&lse, lhs); - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts)); - gfc_add_modify (&block, lse.expr, - fold_convert (TREE_TYPE (lse.expr), tmp)); + gfc_symbol *vtab; + gfc_symtree *st; + vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived); + gcc_assert (vtab); + + rhs = gfc_get_expr (); + rhs->expr_type = EXPR_VARIABLE; + gfc_find_sym_tree (vtab->name, NULL, 1, &st); + rhs->symtree = st; + rhs->ts = vtab->ts; } else if (code->expr2->expr_type == EXPR_NULL) - { - rhs = gfc_int_expr (0); - tmp = gfc_trans_assignment (lhs, rhs, false); - gfc_add_expr_to_block (&block, tmp); - } + rhs = gfc_int_expr (0); else gcc_unreachable (); + tmp = gfc_trans_pointer_assignment (lhs, rhs); + gfc_add_expr_to_block (&block, tmp); + gfc_free_expr (lhs); gfc_free_expr (rhs); } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 4273b82..208a3b5 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -4715,14 +4715,20 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) b = expr->value.function.actual->next->expr; if (a->ts.type == BT_CLASS) - gfc_add_component_ref (a, "$vindex"); + { + gfc_add_component_ref (a, "$vptr"); + gfc_add_component_ref (a, "$hash"); + } else if (a->ts.type == BT_DERIVED) - a = gfc_int_expr (a->ts.u.derived->vindex); + a = gfc_int_expr (a->ts.u.derived->hash_value); if (b->ts.type == BT_CLASS) - gfc_add_component_ref (b, "$vindex"); + { + gfc_add_component_ref (b, "$vptr"); + gfc_add_component_ref (b, "$hash"); + } else if (b->ts.type == BT_DERIVED) - b = gfc_int_expr (b->ts.u.derived->vindex); + b = gfc_int_expr (b->ts.u.derived->hash_value); gfc_conv_expr (&se1, a); gfc_conv_expr (&se2, b); @@ -4733,21 +4739,6 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) } -/* Generate code for the EXTENDS_TYPE_OF intrinsic. */ - -static void -gfc_conv_extends_type_of (gfc_se *se, gfc_expr *expr) -{ - gfc_expr *e; - /* TODO: Implement EXTENDS_TYPE_OF. */ - gfc_error ("Intrinsic EXTENDS_TYPE_OF at %L not yet implemented", - &expr->where); - /* Just return 'false' for now. */ - e = gfc_logical_expr (false, &expr->where); - gfc_conv_expr (se, e); -} - - /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */ static void @@ -5157,10 +5148,6 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_same_type_as (se, expr); break; - case GFC_ISYM_EXTENDS_TYPE_OF: - gfc_conv_extends_type_of (se, expr); - break; - case GFC_ISYM_ABS: gfc_conv_intrinsic_abs (se, expr); break; @@ -5538,6 +5525,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_CHMOD: case GFC_ISYM_DTIME: case GFC_ISYM_ETIME: + case GFC_ISYM_EXTENDS_TYPE_OF: case GFC_ISYM_FGET: case GFC_ISYM_FGETC: case GFC_ISYM_FNUM: diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 0411588..e9f76a0 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -4046,6 +4046,7 @@ gfc_trans_allocate (gfc_code * code) gfc_expr *sz; gfc_se se_sz; sz = gfc_copy_expr (code->expr3); + gfc_add_component_ref (sz, "$vptr"); gfc_add_component_ref (sz, "$size"); gfc_init_se (&se_sz, NULL); gfc_conv_expr (&se_sz, sz); @@ -4141,42 +4142,49 @@ gfc_trans_allocate (gfc_code * code) { gfc_expr *lhs,*rhs; gfc_se lse; - /* Initialize VINDEX for CLASS objects. */ + + /* Initialize VPTR for CLASS objects. */ lhs = gfc_expr_to_initialize (expr); - gfc_add_component_ref (lhs, "$vindex"); + gfc_add_component_ref (lhs, "$vptr"); + rhs = NULL; if (code->expr3 && code->expr3->ts.type == BT_CLASS) { - /* vindex must be determined at run time. */ + /* VPTR must be determined at run time. */ rhs = gfc_copy_expr (code->expr3); - gfc_add_component_ref (rhs, "$vindex"); + gfc_add_component_ref (rhs, "$vptr"); + tmp = gfc_trans_pointer_assignment (lhs, rhs); + gfc_add_expr_to_block (&block, tmp); + gfc_free_expr (rhs); } else { - /* vindex is fixed at compile time. */ - int vindex; + /* VPTR is fixed at compile time. */ + gfc_symbol *vtab; + gfc_typespec *ts; if (code->expr3) - vindex = code->expr3->ts.u.derived->vindex; + ts = &code->expr3->ts; + else if (expr->ts.type == BT_DERIVED) + ts = &expr->ts; else if (code->ext.alloc.ts.type == BT_DERIVED) - vindex = code->ext.alloc.ts.u.derived->vindex; + ts = &code->ext.alloc.ts; else if (expr->ts.type == BT_CLASS) - vindex = expr->ts.u.derived->components->ts.u.derived->vindex; + ts = &expr->ts.u.derived->components->ts; else - vindex = expr->ts.u.derived->vindex; - rhs = gfc_int_expr (vindex); - } - tmp = gfc_trans_assignment (lhs, rhs, false); - gfc_free_expr (lhs); - gfc_free_expr (rhs); - gfc_add_expr_to_block (&block, tmp); + ts = &expr->ts; - /* Initialize SIZE for CLASS objects. */ - lhs = gfc_expr_to_initialize (expr); - gfc_add_component_ref (lhs, "$size"); - gfc_init_se (&lse, NULL); - gfc_conv_expr (&lse, lhs); - gfc_add_modify (&block, lse.expr, - fold_convert (TREE_TYPE (lse.expr), memsz)); - gfc_free_expr (lhs); + if (ts->type == BT_DERIVED) + { + vtab = gfc_find_derived_vtab (ts->u.derived); + gcc_assert (vtab); + gfc_init_se (&lse, NULL); + lse.want_pointer = 1; + gfc_conv_expr (&lse, lhs); + tmp = gfc_build_addr_expr (NULL_TREE, + gfc_get_symbol_decl (vtab)); + gfc_add_modify (&block, lse.expr, + fold_convert (TREE_TYPE (lse.expr), tmp)); + } + } } } diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 1864477..278ae27 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -53,8 +53,6 @@ along with GCC; see the file COPYING3. If not see /* array of structs so we don't have to worry about xmalloc or free */ CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER]; -static tree gfc_get_derived_type (gfc_symbol * derived); - tree gfc_array_index_type; tree gfc_array_range_type; tree gfc_character1_type_node; @@ -1941,7 +1939,7 @@ gfc_get_ppc_type (gfc_component* c) at the same time. If an equal derived type has been built in a parent namespace, this is used. */ -static tree +tree gfc_get_derived_type (gfc_symbol * derived) { tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e4cf40f..d9221faf 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,27 @@ +2009-11-30 Janus Weil <janus@gcc.gnu.org> + + PR fortran/42053 + * gfortran.dg/select_type_9.f03: New. + +2009-11-30 Janus Weil <janus@gcc.gnu.org> + + PR fortran/41631 + * gfortran.dg/extends_type_of_1.f03: Fix invalid test case. + * gfortran.dg/module_md5_1.f90: Adjusted MD5 sum. + * gfortran.dg/select_type_1.f03: Remove FIXMEs. + * gfortran.dg/select_type_2.f03: Ditto. + * gfortran.dg/select_type_8.f03: New test. + +2009-11-30 Janus Weil <janus@gcc.gnu.org> + + * gfortran.dg/extends_type_of_1.f03: New test. + * gfortran.dg/same_type_as_1.f03: Extended. + +2009-11-30 Paul Thomas <pault@gcc.gnu.org> + + * gfortran.dg/class_4c.f03: Add dg-additional-sources. + * gfortran.dg/class_4d.f03: Rename module. Cleanup modules. + 2009-11-30 Janis Johnson <janis187@us.ibm.com> PR testsuite/42212 diff --git a/gcc/testsuite/gfortran.dg/class_4c.f03 b/gcc/testsuite/gfortran.dg/class_4c.f03 index 7909c0e..c76b3ab 100644 --- a/gcc/testsuite/gfortran.dg/class_4c.f03 +++ b/gcc/testsuite/gfortran.dg/class_4c.f03 @@ -1,4 +1,5 @@ ! { dg-do run } +! { dg-additional-sources class_4a.f03 class_4b.f03 } ! ! Test the fix for PR41583, in which the different source files ! would generate the same 'vindex' for different class declared diff --git a/gcc/testsuite/gfortran.dg/class_4d.f03 b/gcc/testsuite/gfortran.dg/class_4d.f03 index 7a962aa..80934b6 100644 --- a/gcc/testsuite/gfortran.dg/class_4d.f03 +++ b/gcc/testsuite/gfortran.dg/class_4d.f03 @@ -8,8 +8,8 @@ ! ! Contributed by Tobias Burnus <burnus@gcc.gnu.org> ! -module m +module m3 type t end type t -end module m -! { dg-final { cleanup-modules "m m2" } } +end module m3 +! { dg-final { cleanup-modules "m m2 m3" } } diff --git a/gcc/testsuite/gfortran.dg/extends_type_of_1.f03 b/gcc/testsuite/gfortran.dg/extends_type_of_1.f03 new file mode 100644 index 0000000..9e98384 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/extends_type_of_1.f03 @@ -0,0 +1,48 @@ +! { dg-do run } +! +! Verifying the runtime behavior of the intrinsic function EXTENDS_TYPE_OF. +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + + implicit none + + intrinsic :: extends_type_of + + type :: t1 + integer :: i = 42 + end type + + type, extends(t1) :: t2 + integer :: j = 43 + end type + + type, extends(t2) :: t3 + class(t1),pointer :: cc + end type + + class(t1), pointer :: c1,c2 + type(t1), target :: x + type(t2), target :: y + type(t3), target :: z + + c1 => x + c2 => y + z%cc => y + + if (.not. extends_type_of (c1, c1)) call abort() + if ( extends_type_of (c1, c2)) call abort() + if (.not. extends_type_of (c2, c1)) call abort() + + if (.not. extends_type_of (x, x)) call abort() + if ( extends_type_of (x, y)) call abort() + if (.not. extends_type_of (y, x)) call abort() + + if (.not. extends_type_of (c1, x)) call abort() + if ( extends_type_of (c1, y)) call abort() + if (.not. extends_type_of (x, c1)) call abort() + if (.not. extends_type_of (y, c1)) call abort() + + if (.not. extends_type_of (z, c1)) call abort() + if ( extends_type_of (z%cc, z)) call abort() + +end diff --git a/gcc/testsuite/gfortran.dg/module_md5_1.f90 b/gcc/testsuite/gfortran.dg/module_md5_1.f90 index 88002c2..e725b4b 100644 --- a/gcc/testsuite/gfortran.dg/module_md5_1.f90 +++ b/gcc/testsuite/gfortran.dg/module_md5_1.f90 @@ -10,5 +10,5 @@ program test use foo print *, pi end program test -! { dg-final { scan-module "foo" "MD5:9c43cf4d713824ec6894b83250720e68" } } +! { dg-final { scan-module "foo" "MD5:5632bcd379cf023bf7e663e91d52fa12" } } ! { dg-final { cleanup-modules "foo" } } diff --git a/gcc/testsuite/gfortran.dg/same_type_as_1.f03 b/gcc/testsuite/gfortran.dg/same_type_as_1.f03 index ba13a0b..45b5d26 100644 --- a/gcc/testsuite/gfortran.dg/same_type_as_1.f03 +++ b/gcc/testsuite/gfortran.dg/same_type_as_1.f03 @@ -1,6 +1,6 @@ ! { dg-do compile } ! -! Error checking for the intrinsic function SAME_TYPE_AS. +! Error checking for the intrinsic functions SAME_TYPE_AS and EXTENDS_TYPE_OF. ! ! Contributed by Janus Weil <janus@gcc.gnu.org> @@ -18,7 +18,10 @@ integer :: i - print *, SAME_TYPE_AS (l,x1) ! { dg-error "must be of a derived type" } + print *, SAME_TYPE_AS (i,x1) ! { dg-error "must be of a derived type" } print *, SAME_TYPE_AS (x1,x2) ! { dg-error "must be of an extensible type" } + print *, EXTENDS_TYPE_OF (i,x1) ! { dg-error "must be of a derived type" } + print *, EXTENDS_TYPE_OF (x1,x2) ! { dg-error "must be of an extensible type" } + end diff --git a/gcc/testsuite/gfortran.dg/select_type_1.f03 b/gcc/testsuite/gfortran.dg/select_type_1.f03 index 6a7db2e..0214c51 100644 --- a/gcc/testsuite/gfortran.dg/select_type_1.f03 +++ b/gcc/testsuite/gfortran.dg/select_type_1.f03 @@ -40,16 +40,14 @@ print *,"a is TYPE(t1)" type is (t2) print *,"a is TYPE(t2)" -! FIXME: CLASS IS specification is not yet supported -! class is (ts) ! { FIXME: error "must be extensible" } -! print *,"a is TYPE(ts)" + class is (ts) ! { dg-error "must be extensible" } + print *,"a is TYPE(ts)" type is (t3) ! { dg-error "must be an extension of" } print *,"a is TYPE(t3)" type is (t4) ! { dg-error "is not an accessible derived type" } print *,"a is TYPE(t3)" -! FIXME: CLASS IS specification is not yet supported -! class is (t1) -! print *,"a is CLASS(t1)" + class is (t1) + print *,"a is CLASS(t1)" class is (t2) label ! { dg-error "Syntax error" } print *,"a is CLASS(t2)" class default ! { dg-error "cannot be followed by a second DEFAULT CASE" } diff --git a/gcc/testsuite/gfortran.dg/select_type_2.f03 b/gcc/testsuite/gfortran.dg/select_type_2.f03 index 08ac9fe..d4a5343 100644 --- a/gcc/testsuite/gfortran.dg/select_type_2.f03 +++ b/gcc/testsuite/gfortran.dg/select_type_2.f03 @@ -30,9 +30,8 @@ i = 1 type is (t2) i = 2 -! FIXME: CLASS IS is not yet supported -! class is (t1) -! i = 3 + class is (t1) + i = 3 end select if (i /= 1) call abort() @@ -45,9 +44,8 @@ i = 1 type is (t2) i = 2 -! FIXME: CLASS IS is not yet supported -! class is (t2) -! i = 3 + class is (t2) + i = 3 end select if (i /= 2) call abort() diff --git a/gcc/testsuite/gfortran.dg/select_type_8.f03 b/gcc/testsuite/gfortran.dg/select_type_8.f03 new file mode 100644 index 0000000..306f2d1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_8.f03 @@ -0,0 +1,98 @@ +! { dg-do run } +! +! executing SELECT TYPE statements with CLASS IS blocks +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + + implicit none + + type :: t1 + integer :: i + end type t1 + + type, extends(t1) :: t2 + integer :: j + end type t2 + + type, extends(t2) :: t3 + real :: r + end type + + class(t1), pointer :: cp + type(t1), target :: a + type(t2), target :: b + type(t3), target :: c + integer :: i + + cp => c + i = 0 + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 + class is (t1) + i = 3 + class default + i = 4 + end select + print *,i + if (i /= 3) call abort() + + cp => a + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 + class is (t1) + i = 3 + end select + print *,i + if (i /= 1) call abort() + + cp => b + select type (cp) + type is (t1) + i = 1 + class is (t3) + i = 3 + class is (t2) + i = 4 + class is (t1) + i = 5 + end select + print *,i + if (i /= 4) call abort() + + cp => b + select type (cp) + type is (t1) + i = 1 + class is (t1) + i = 5 + class is (t2) + i = 4 + class is (t3) + i = 3 + end select + print *,i + if (i /= 4) call abort() + + cp => a + select type (cp) + type is (t2) + i = 1 + class is (t2) + i = 2 + class default + i = 3 + class is (t3) + i = 4 + type is (t3) + i = 5 + end select + print *,i + if (i /= 3) call abort() + +end diff --git a/gcc/testsuite/gfortran.dg/select_type_9.f03 b/gcc/testsuite/gfortran.dg/select_type_9.f03 new file mode 100644 index 0000000..62df670 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_9.f03 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR 42053: [OOP] SELECT TYPE: reject duplicate CLASS IS blocks +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + + type :: t + integer :: i + end type + + CLASS(t),pointer :: x + + select type (x) + class is (t) + print *,"a" + class is (t) ! { dg-error "Double CLASS IS block" } + print *,"b" + end select + +end |