diff options
Diffstat (limited to 'gcc')
55 files changed, 1845 insertions, 323 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index addfcbeede8..04aac0c2936 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,188 @@ +2009-09-30 Janus Weil <janus@gcc.gnu.org> + + * check.c (gfc_check_same_type_as): New function for checking + SAME_TYPE_AS and EXTENDS_TYPE_OF. + * decl.c (encapsulate_class_symbol): Set ABSTRACT attribute for class + container, if the contained type has it. Add an initializer for the + class container. + (add_init_expr_to_sym): Handle BT_CLASS. + (vindex_counter): New counter for setting vindices. + (gfc_match_derived_decl): Set vindex for all derived types, not only + those which are being extended. + * expr.c (gfc_check_assign_symbol): Handle NULL initialization of class + pointers. + * gfortran.h (gfc_isym_id): New values GFC_ISYM_SAME_TYPE_AS and + GFC_ISYM_EXTENDS_TYPE_OF. + (gfc_type_is_extensible): New prototype. + * intrinsic.h (gfc_check_same_type_as): New prototype. + * intrinsic.c (add_functions): Add SAME_TYPE_AS and EXTENDS_TYPE_OF. + * primary.c (gfc_expr_attr): Handle CLASS-valued functions. + * resolve.c (resolve_structure_cons): Handle BT_CLASS. + (type_is_extensible): Make non-static and rename to + 'gfc_type_is_extensible. + (resolve_select_type): Renamed type_is_extensible. + (resolve_class_assign): Handle NULL pointers. + (resolve_fl_variable_derived): Renamed type_is_extensible. + (resolve_fl_derived): Ditto. + * trans-expr.c (gfc_trans_subcomponent_assign): Handle NULL + initialization of class pointer components. + (gfc_conv_structure): Handle BT_CLASS. + * trans-intrinsic.c (gfc_conv_same_type_as,gfc_conv_extends_type_of): + New functions. + (gfc_conv_intrinsic_function): Handle SAME_TYPE_AS and EXTENDS_TYPE_OF. + +2009-09-30 Janus Weil <janus@gcc.gnu.org> + + * gfortran.h (type_selector, select_type_tmp): New global variables. + * match.c (type_selector, select_type_tmp): New global variables, + used for SELECT TYPE statements. + (gfc_match_select_type): Better error handling. Remember selector. + (gfc_match_type_is): Create temporary variable. + * module.c (ab_attribute): New value 'AB_IS_CLASS'. + (attr_bits): New string. + (mio_symbol_attribute): Handle 'is_class'. + * resolve.c (resolve_select_type): Insert pointer assignment statement, + to assign temporary to selector. + * symbol.c (gfc_get_ha_sym_tree): Replace selector by a temporary + in SELECT TYPE statements. + +2009-09-30 Janus Weil <janus@gcc.gnu.org> + + * dump-parse-tree.c (show_code_node): Renamed 'alloc_list'. + * gfortran.h (gfc_code): Rename 'alloc_list'. Add member 'ts'. + (gfc_expr_to_initialize): New prototype. + * match.c (alloc_opt_list): Correctly check type compatibility. + Renamed 'alloc_list'. + (dealloc_opt_list): Renamed 'alloc_list'. + * resolve.c (expr_to_initialize): Rename to 'gfc_expr_to_initialize' + and make it non-static. + (resolve_allocate_expr): Set vindex for CLASS variables correctly. + Move initialization code to gfc_trans_allocate. Renamed 'alloc_list'. + (resolve_allocate_deallocate): Renamed 'alloc_list'. + (check_class_pointer_assign): Rename to 'resolve_class_assign'. Change + argument type. Adjust to work with ordinary assignments. + (resolve_code): Call 'resolve_class_assign' for ordinary assignments. + Renamed 'check_class_pointer_assign'. + * st.c (gfc_free_statement): Renamed 'alloc_list'. + * trans-stmt.c (gfc_trans_allocate): Renamed 'alloc_list'. Handle + size determination and initialization of CLASS variables. Bugfix for + ALLOCATE statements with default initialization and SOURCE block. + (gfc_trans_deallocate): Renamed 'alloc_list'. + +2009-09-30 Paul Thomas <pault@gcc.gnu.org> + + * trans-expr.c (gfc_conv_procedure_call): Convert a derived + type actual to a class object if the formal argument is a + class. + +2009-09-30 Janus Weil <janus@gcc.gnu.org> + + PR fortran/40996 + * decl.c (build_struct): Handle allocatable scalar components. + * expr.c (gfc_add_component_ref): Correctly set typespec of expression, + after inserting component reference. + * match.c (gfc_match_type_is,gfc_match_class_is): Make sure that no + variables are being used uninitialized. + * primary.c (gfc_match_varspec): Handle CLASS array components. + * resolve.c (resolve_select_type): Transform EXEC_SELECT_TYPE to + EXEC_SELECT. + * trans-array.c (structure_alloc_comps,gfc_trans_deferred_array): + Handle allocatable scalar components. + * trans-expr.c (gfc_conv_component_ref): Ditto. + * trans-types.c (gfc_get_derived_type): Ditto. + +2009-09-30 Janus Weil <janus@gcc.gnu.org> + + * decl.c (encapsulate_class_symbol): Modify names of class container + components by prefixing with '$'. + (gfc_match_end): Handle COMP_SELECT_TYPE. + * expr.c (gfc_add_component_ref): Modify names of class container + components by prefixing with '$'. + * gfortran.h (gfc_statement): Add ST_SELECT_TYPE, ST_TYPE_IS and + ST_CLASS_IS. + (gfc_case): New field 'ts'. + (gfc_exec_op): Add EXEC_SELECT_TYPE. + (gfc_type_is_extension_of): New prototype. + * match.h (gfc_match_select_type,gfc_match_type_is,gfc_match_class_is): + New prototypes. + * match.c (match_derived_type_spec): New function. + (match_type_spec): Use 'match_derived_type_spec'. + (match_case_eos): Modify error message. + (gfc_match_select_type): New function. + (gfc_match_case): Modify error message. + (gfc_match_type_is): New function. + (gfc_match_class_is): Ditto. + * parse.h (gfc_compile_state): Add COMP_SELECT_TYPE. + * parse.c (decode_statement): Handle SELECT TYPE, TYPE IS and CLASS IS + statements. + (next_statement): Handle ST_SELECT_TYPE. + (gfc_ascii_statement): Handle ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS. + (parse_select_type_block): New function. + (parse_executable): Handle ST_SELECT_TYPE. + * resolve.c (resolve_deallocate_expr): Handle BT_CLASS. Modify names of + class container components by prefixing with '$'. + (resolve_allocate_expr): Ditto. + (resolve_select_type): New function. + (gfc_resolve_blocks): Handle EXEC_SELECT_TYPE. + (check_class_pointer_assign): Modify names of class container + components by prefixing with '$'. + (resolve_code): Ditto. + * st.c (gfc_free_statement): Ditto. + * symbol.c (gfc_type_is_extension_of): New function. + (gfc_type_compatible): Use 'gfc_type_is_extension_of', plus a bugfix. + * trans.c (gfc_trans_code): Handel EXEC_SELECT_TYPE. + +2009-09-30 Janus Weil <janus@gcc.gnu.org> + Paul Thomas <pault@gcc.gnu.org> + + * check.c (gfc_check_move_alloc): Arguments don't have to be arrays. + The second argument needs to be type-compatible with the first (not the + other way around, which makes a difference for CLASS entities). + * decl.c (encapsulate_class_symbol): New function. + (build_sym,build_struct): Handle BT_CLASS, call + 'encapsulate_class_symbol'. + (gfc_match_decl_type_spec): Remove warning, use BT_CLASS. + (gfc_match_derived_decl): Set vindex; + * expr.c (gfc_add_component_ref): New function. + (gfc_copy_expr,gfc_check_pointer_assign,gfc_check_assign_symbol): + Handle BT_CLASS. + * dump-parse-tree.c (show_symbol): Print vindex. + * gfortran.h (bt): New basic type BT_CLASS. + (symbol_attribute): New field 'is_class'. + (gfc_typespec): Remove field 'is_class'. + (gfc_symbol): New field 'vindex'. + (gfc_get_ultimate_derived_super_type): New prototype. + (gfc_add_component_ref): Ditto. + * interface.c (gfc_compare_derived_types): Pointer equality check + moved here from gfc_compare_types. + (gfc_compare_types): Handle BT_CLASS and use + gfc_type_compatible. + * match.c (gfc_match_allocate,gfc_match_deallocate,gfc_match_call): + Handle BT_CLASS. + * misc.c (gfc_clear_ts): Removed is_class. + (gfc_basic_typename,gfc_typename): Handle BT_CLASS. + * module.c (bt_types,mio_typespec): Handle BT_CLASS. + (mio_symbol): Handle vindex. + * primary.c (gfc_match_varspec,gfc_variable_attr): Handle BT_CLASS. + * resolve.c (find_array_spec,check_typebound_baseobject): + Handle BT_CLASS. + (resolve_ppc_call,resolve_expr_ppc): Don't call 'gfc_is_proc_ptr_comp' + inside 'gcc_assert'. + (resolve_deallocate_expr,resolve_allocate_expr): Handle BT_CLASS. + (check_class_pointer_assign): New function. + (resolve_code): Handle BT_CLASS, call check_class_pointer_assign. + (resolve_fl_var_and_proc,type_is_extensible,resolve_fl_variable_derived, + resolve_fl_variable): Handle BT_CLASS. + (check_generic_tbp_ambiguity): Add special case. + (resolve_typebound_procedure,resolve_fl_derived): Handle BT_CLASS. + * symbol.c (gfc_get_ultimate_derived_super_type): New function. + (gfc_type_compatible): Handle BT_CLASS. + * trans-expr.c (conv_parent_component_references): Handle CLASS + containers. + (gfc_conv_initializer): Handle BT_CLASS. + * trans-types.c (gfc_typenode_for_spec,gfc_get_derived_type): + Handle BT_CLASS. + 2009-09-29 Daniel Kraft <d@domob.eu> PR fortran/39626 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 01775abdd30..171eeaa97bf 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2135,9 +2135,6 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) if (variable_check (from, 0) == FAILURE) return FAILURE; - if (array_check (from, 0) == FAILURE) - return FAILURE; - attr = gfc_variable_attr (from, NULL); if (!attr.allocatable) { @@ -2150,9 +2147,6 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) if (variable_check (to, 0) == FAILURE) return FAILURE; - if (array_check (to, 0) == FAILURE) - return FAILURE; - attr = gfc_variable_attr (to, NULL); if (!attr.allocatable) { @@ -2162,7 +2156,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) return FAILURE; } - if (same_type_check (from, 0, to, 1) == FAILURE) + if (same_type_check (to, 1, from, 0) == FAILURE) return FAILURE; if (to->rank != from->rank) @@ -2647,6 +2641,46 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, gfc_try +gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) +{ + + if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L " + "must be of a derived type", gfc_current_intrinsic_arg[0], + gfc_current_intrinsic, &a->where); + return FAILURE; + } + + if (!gfc_type_is_extensible (a->ts.u.derived)) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L " + "must be of an extensible type", gfc_current_intrinsic_arg[0], + gfc_current_intrinsic, &a->where); + return FAILURE; + } + + if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L " + "must be of a derived type", gfc_current_intrinsic_arg[1], + gfc_current_intrinsic, &b->where); + return FAILURE; + } + + if (!gfc_type_is_extensible (b->ts.u.derived)) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L " + "must be of an extensible type", gfc_current_intrinsic_arg[1], + gfc_current_intrinsic, &b->where); + return FAILURE; + } + + return SUCCESS; +} + + +gfc_try gfc_check_scale (gfc_expr *x, gfc_expr *i) { if (type_check (x, 0, BT_REAL) == FAILURE) diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index cfd8b8126ea..20718ca5161 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1025,6 +1025,79 @@ 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. */ + +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->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); + } + + 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. */ static gfc_try @@ -1097,6 +1170,9 @@ 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); + return SUCCESS; } @@ -1250,6 +1326,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) /* Check if the assignment can happen. This has to be put off until later for a derived type variable. */ if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED + && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS && gfc_check_assign_symbol (sym, init) == FAILURE) return FAILURE; @@ -1467,17 +1544,12 @@ 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) - { - if (c->attr.allocatable) - { - gfc_error ("Allocatable component at %C must be an array"); - return FAILURE; - } - else - return SUCCESS; - } + return SUCCESS; if (c->attr.pointer) { @@ -2370,24 +2442,20 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) } m = gfc_match (" type ( %n )", name); - if (m != MATCH_YES) + if (m == MATCH_YES) + ts->type = BT_DERIVED; + else { m = gfc_match (" class ( %n )", name); if (m != MATCH_YES) return m; - ts->is_class = 1; + ts->type = BT_CLASS; if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: CLASS statement at %C") == FAILURE) return MATCH_ERROR; - - /* TODO: Implement Polymorphism. */ - gfc_warning ("Polymorphic entities are not yet implemented. " - "CLASS will be treated like TYPE at %C"); } - ts->type = BT_DERIVED; - /* Defer association of the derived type until the end of the specification block. However, if the derived type can be found, add it to the typespec. */ @@ -5441,6 +5509,7 @@ gfc_match_end (gfc_statement *st) break; case COMP_SELECT: + case COMP_SELECT_TYPE: *st = ST_END_SELECT; target = " select"; eos_ok = 0; @@ -6703,6 +6772,10 @@ 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; + + /* Match the beginning of a derived type declaration. If a type name was the result of a function, then it is possible to have a symbol already to be known as a derived type yet have no components. */ @@ -6823,6 +6896,10 @@ gfc_match_derived_decl (void) st->n.sym = sym; } + if (!sym->vindex) + /* Set the vindex for this type and increment the counter. */ + sym->vindex = ++vindex_counter; + /* 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 8480e40593a..32ff298d6e0 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -825,7 +825,12 @@ show_symbol (gfc_symbol *sym) } if (sym->f2k_derived) - show_f2k_derived (sym->f2k_derived); + { + show_indent (); + if (sym->vindex) + fprintf (dumpfile, "vindex: %d", sym->vindex); + show_f2k_derived (sym->f2k_derived); + } if (sym->formal) { @@ -1448,7 +1453,7 @@ show_code_node (int level, gfc_code *c) show_expr (c->expr2); } - for (a = c->ext.alloc_list; a; a = a->next) + for (a = c->ext.alloc.list; a; a = a->next) { fputc (' ', dumpfile); show_expr (a->expr); @@ -1470,7 +1475,7 @@ show_code_node (int level, gfc_code *c) show_expr (c->expr2); } - for (a = c->ext.alloc_list; a; a = a->next) + for (a = c->ext.alloc.list; a; a = a->next) { fputc (' ', dumpfile); show_expr (a->expr); diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 970c25939cf..32aa68265bb 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -330,6 +330,36 @@ gfc_has_vector_index (gfc_expr *e) } +/* Insert a reference to the component of the given name. + Only to be used with CLASS containers. */ + +void +gfc_add_component_ref (gfc_expr *e, const char *name) +{ + gfc_ref **tail = &(e->ref); + gfc_ref *next = NULL; + gfc_symbol *derived = e->symtree->n.sym->ts.u.derived; + while (*tail != NULL) + { + if ((*tail)->type == REF_COMPONENT) + derived = (*tail)->u.c.component->ts.u.derived; + if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL) + break; + tail = &((*tail)->next); + } + if (*tail != NULL && strcmp (name, "$data") == 0) + next = *tail; + (*tail) = gfc_get_ref(); + (*tail)->next = next; + (*tail)->type = REF_COMPONENT; + (*tail)->u.c.sym = derived; + (*tail)->u.c.component = gfc_find_component (derived, name, true, true); + gcc_assert((*tail)->u.c.component); + if (!next) + e->ts = (*tail)->u.c.component->ts; +} + + /* Copy a shape array. */ mpz_t * @@ -481,6 +511,7 @@ gfc_copy_expr (gfc_expr *p) case BT_HOLLERITH: case BT_LOGICAL: case BT_DERIVED: + case BT_CLASS: break; /* Already done. */ case BT_PROCEDURE: @@ -3124,7 +3155,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return FAILURE; } - if (!pointer && !proc_pointer) + if (!pointer && !proc_pointer + && !(lvalue->ts.type == BT_CLASS + && lvalue->ts.u.derived->components->attr.pointer)) { gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where); return FAILURE; @@ -3244,7 +3277,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return SUCCESS; } - if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) + if (lvalue->ts.type != BT_CLASS && lvalue->symtree->n.sym->ts.type != BT_CLASS + && !gfc_compare_types (&lvalue->ts, &rvalue->ts)) { gfc_error ("Different types in pointer assignment at %L; attempted " "assignment of %s to %s", &lvalue->where, @@ -3252,7 +3286,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return FAILURE; } - if (lvalue->ts.kind != rvalue->ts.kind) + if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind) { gfc_error ("Different kind type parameters in pointer " "assignment at %L", &lvalue->where); @@ -3332,7 +3366,10 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) lvalue.symtree->n.sym = sym; lvalue.where = sym->declared_at; - if (sym->attr.pointer || sym->attr.proc_pointer) + if (sym->attr.pointer || sym->attr.proc_pointer + || (sym->ts.type == BT_CLASS + && sym->ts.u.derived->components->attr.pointer + && rvalue->expr_type == EXPR_NULL)) r = gfc_check_pointer_assign (&lvalue, rvalue); else r = gfc_check_assign (&lvalue, rvalue, 1); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 0dce218b22c..326112df482 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -142,9 +142,8 @@ gfc_source_form; /* Basic types. BT_VOID is used by ISO C Binding so funcs like c_f_pointer can take any arg with the pointer attribute as a param. */ typedef enum -{ BT_UNKNOWN = 1, BT_INTEGER, BT_REAL, BT_COMPLEX, - BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE, BT_HOLLERITH, - BT_VOID +{ BT_UNKNOWN = 1, BT_INTEGER, BT_REAL, BT_COMPLEX, BT_LOGICAL, BT_CHARACTER, + BT_DERIVED, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID } bt; @@ -222,7 +221,7 @@ typedef enum ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT, ST_WRITE, ST_ASSIGNMENT, ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, ST_SIMPLE_IF, ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT, - ST_ENUM, ST_ENUMERATOR, ST_END_ENUM, + ST_ENUM, ST_ENUMERATOR, ST_END_ENUM, ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS, ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, ST_OMP_END_CRITICAL, ST_OMP_END_DO, ST_OMP_END_MASTER, ST_OMP_END_ORDERED, ST_OMP_END_PARALLEL, ST_OMP_END_PARALLEL_DO, ST_OMP_END_PARALLEL_SECTIONS, @@ -364,6 +363,7 @@ enum gfc_isym_id GFC_ISYM_EXIT, GFC_ISYM_EXP, GFC_ISYM_EXPONENT, + GFC_ISYM_EXTENDS_TYPE_OF, GFC_ISYM_FDATE, GFC_ISYM_FGET, GFC_ISYM_FGETC, @@ -478,6 +478,7 @@ enum gfc_isym_id GFC_ISYM_RESHAPE, GFC_ISYM_RRSPACING, GFC_ISYM_RSHIFT, + GFC_ISYM_SAME_TYPE_AS, GFC_ISYM_SC_KIND, GFC_ISYM_SCALE, GFC_ISYM_SCAN, @@ -670,6 +671,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. */ /* These flags are both in the typespec and attribute. The attribute list is what gets read from/written to a module file. The typespec @@ -849,7 +851,6 @@ typedef struct u; struct gfc_symbol *interface; /* For PROCEDURE declarations. */ - unsigned int is_class:1; int is_c_interop; int is_iso_c; bt f90_type; @@ -1133,6 +1134,11 @@ typedef struct gfc_symbol /* Defined only for Cray pointees; points to their pointer. */ struct gfc_symbol *cp_pointer; + int entry_id; /* Used in resolve.c for entries. */ + + /* CLASS vindex for declared and dynamic types in the class. */ + int vindex; + struct gfc_symbol *common_next; /* Links for COMMON syms */ /* This is in fact a gfc_common_head but it is only used for pointer @@ -1143,8 +1149,6 @@ typedef struct gfc_symbol order. */ int dummy_order; - int entry_id; - gfc_namelist *namelist, *namelist_tail; /* Change management fields. Symbols that might be modified by the @@ -1856,6 +1860,9 @@ typedef struct gfc_case represents the default case. */ gfc_expr *low, *high; + /* Only used for SELECT TYPE. */ + gfc_typespec ts; + /* Next case label in the list of cases for a single CASE label. */ struct gfc_case *next; @@ -1972,7 +1979,7 @@ typedef enum EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN, EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_BLOCK, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_CALL_PPC, - EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE, + EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE, EXEC_SELECT_TYPE, EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT, EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END, EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH, @@ -2006,7 +2013,14 @@ typedef struct gfc_code gfc_actual_arglist *actual; gfc_case *case_list; gfc_iterator *iterator; - gfc_alloc *alloc_list; + + struct + { + gfc_typespec ts; + gfc_alloc *list; + } + alloc; + gfc_open *open; gfc_close *close; gfc_filepos *filepos; @@ -2476,6 +2490,8 @@ gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *); 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*); +bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *); bool gfc_type_compatible (gfc_typespec *, gfc_typespec *); gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool, locus*); @@ -2534,6 +2550,10 @@ void gfc_free_equiv (gfc_equiv *); void gfc_free_data (gfc_data *); void gfc_free_case_list (gfc_case *); +/* Used for SELECT TYPE statements. */ +extern gfc_symbol *type_selector; +extern gfc_symtree *select_type_tmp; + /* matchexp.c -- FIXME too? */ gfc_expr *gfc_get_parentheses (gfc_expr *); @@ -2548,9 +2568,9 @@ void gfc_resolve_omp_do_blocks (gfc_code *, gfc_namespace *); void gfc_free_actual_arglist (gfc_actual_arglist *); gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *); const char *gfc_extract_int (gfc_expr *, int *); -gfc_expr *gfc_expr_to_initialize (gfc_expr *); bool is_subref_array (gfc_expr *); +void gfc_add_component_ref (gfc_expr *, const char *); gfc_expr *gfc_build_conversion (gfc_expr *); void gfc_free_ref_list (gfc_ref *); void gfc_type_convert_binary (gfc_expr *); @@ -2614,6 +2634,8 @@ gfc_try gfc_resolve_dim_arg (gfc_expr *); int gfc_is_formal_arg (void); void gfc_resolve_substring_charlen (gfc_expr *); match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *); +gfc_expr *gfc_expr_to_initialize (gfc_expr *); +bool gfc_type_is_extensible (gfc_symbol *sym); /* array.c */ diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 132f10a47c7..0fd4742a1de 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -360,6 +360,9 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) { gfc_component *dt1, *dt2; + if (derived1 == derived2) + return 1; + /* Special case for comparing derived types across namespaces. If the true names and module names are the same and the module name is nonnull, then they are equal. */ @@ -448,13 +451,15 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) if (ts1->type == BT_VOID || ts2->type == BT_VOID) return 1; - if (ts1->type != ts2->type) + if (ts1->type != ts2->type + && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS) + || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS))) return 0; - if (ts1->type != BT_DERIVED) + if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS) return (ts1->kind == ts2->kind); /* Compare derived types. */ - if (ts1->u.derived == ts2->u.derived) + if (gfc_type_compatible (ts1, ts2)) return 1; return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived); diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index d2cdb591888..3e8e3f2e5a4 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1599,6 +1599,12 @@ add_functions (void) make_generic ("exponent", GFC_ISYM_EXPONENT, GFC_STD_F95); + 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, + a, BT_UNKNOWN, 0, REQUIRED, + mo, BT_UNKNOWN, 0, REQUIRED); + add_sym_0 ("fdate", GFC_ISYM_FDATE, NO_CLASS, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_GNU, NULL, NULL, gfc_resolve_fdate); @@ -2307,6 +2313,12 @@ add_functions (void) make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95); + add_sym_2 ("same_type_as", GFC_ISYM_SAME_TYPE_AS, CLASS_INQUIRY, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_F2003, + gfc_check_same_type_as, NULL, NULL, + a, BT_UNKNOWN, 0, REQUIRED, + b, BT_UNKNOWN, 0, REQUIRED); + add_sym_2 ("scale", GFC_ISYM_SCALE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale, x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index a239ad6d35b..acd3f7896d0 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -119,6 +119,7 @@ gfc_try gfc_check_real (gfc_expr *, gfc_expr *); gfc_try gfc_check_rename (gfc_expr *, gfc_expr *); gfc_try gfc_check_repeat (gfc_expr *, gfc_expr *); gfc_try gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +gfc_try gfc_check_same_type_as (gfc_expr *, gfc_expr *); gfc_try gfc_check_scale (gfc_expr *, gfc_expr *); gfc_try gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_second_sub (gfc_expr *); diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 919d5d148fc..3e969e78ca2 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -29,6 +29,10 @@ along with GCC; see the file COPYING3. If not see int gfc_matching_procptr_assignment = 0; bool gfc_matching_prefix = false; +/* Used for SELECT TYPE statements. */ +gfc_symbol *type_selector; +gfc_symtree *select_type_tmp; + /* For debugging and diagnostic purposes. Return the textual representation of the intrinsic operator OP. */ const char * @@ -2245,6 +2249,39 @@ gfc_free_alloc_list (gfc_alloc *p) } +/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of + an accessible derived type. */ + +static match +match_derived_type_spec (gfc_typespec *ts) +{ + locus old_locus; + gfc_symbol *derived; + + old_locus = gfc_current_locus; + + if (gfc_match_symbol (&derived, 1) == MATCH_YES) + { + if (derived->attr.flavor == FL_DERIVED) + { + ts->type = BT_DERIVED; + ts->u.derived = derived; + return MATCH_YES; + } + else + { + /* Enforce F03:C476. */ + gfc_error ("'%s' at %L is not an accessible derived type", + derived->name, &gfc_current_locus); + return MATCH_ERROR; + } + } + + gfc_current_locus = old_locus; + return MATCH_NO; +} + + /* Match a Fortran 2003 type-spec (F03:R401). This is similar to gfc_match_decl_type_spec() from decl.c, with the following exceptions: It only includes the intrinsic types from the Fortran 2003 standard @@ -2256,7 +2293,6 @@ static match match_type_spec (gfc_typespec *ts) { match m; - gfc_symbol *derived; locus old_locus; gfc_clear_ts (ts); @@ -2303,43 +2339,27 @@ match_type_spec (gfc_typespec *ts) goto kind_selector; } - if (gfc_match_symbol (&derived, 1) == MATCH_YES) + m = match_derived_type_spec (ts); + if (m == MATCH_YES) { - if (derived->attr.flavor == FL_DERIVED) - { - old_locus = gfc_current_locus; - if (gfc_match (" :: ") != MATCH_YES) - return MATCH_ERROR; - gfc_current_locus = old_locus; - ts->type = BT_DERIVED; - ts->u.derived = derived; - /* Enfore F03:C401. */ - if (derived->attr.abstract) - { - gfc_error ("Derived type '%s' at %L may not be ABSTRACT", - derived->name, &old_locus); - return MATCH_ERROR; - } - return MATCH_YES; - } - else + old_locus = gfc_current_locus; + if (gfc_match (" :: ") != MATCH_YES) + return MATCH_ERROR; + gfc_current_locus = old_locus; + /* Enfore F03:C401. */ + if (ts->u.derived->attr.abstract) { - if (gfc_match (" :: ") == MATCH_YES) - { - /* Enforce F03:C476. */ - gfc_error ("'%s' at %L is not an accessible derived type", - derived->name, &old_locus); - return MATCH_ERROR; - } - else - { - gfc_current_locus = old_locus; - return MATCH_NO; - } + gfc_error ("Derived type '%s' at %L may not be ABSTRACT", + ts->u.derived->name, &old_locus); + return MATCH_ERROR; } + return MATCH_YES; } + else if (m == MATCH_ERROR && gfc_match (" :: ") == MATCH_YES) + return MATCH_ERROR; - /* If a type is not matched, simply return MATCH_NO. */ + /* If a type is not matched, simply return MATCH_NO. */ + gfc_current_locus = old_locus; return MATCH_NO; kind_selector: @@ -2429,6 +2449,7 @@ gfc_match_allocate (void) gfc_alloc *head, *tail; gfc_expr *stat, *errmsg, *tmp, *source; gfc_typespec ts; + gfc_symbol *sym; match m; locus old_locus; bool saw_stat, saw_errmsg, saw_source, b1, b2, b3; @@ -2513,19 +2534,20 @@ gfc_match_allocate (void) tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived); /* FIXME: disable the checking on derived types and arrays. */ + sym = tail->expr->symtree->n.sym; b1 = !(tail->expr->ref && (tail->expr->ref->type == REF_COMPONENT || tail->expr->ref->type == REF_ARRAY)); - b2 = tail->expr->symtree->n.sym - && !(tail->expr->symtree->n.sym->attr.allocatable - || tail->expr->symtree->n.sym->attr.pointer - || tail->expr->symtree->n.sym->attr.proc_pointer); - b3 = tail->expr->symtree->n.sym - && tail->expr->symtree->n.sym->ns - && tail->expr->symtree->n.sym->ns->proc_name - && (tail->expr->symtree->n.sym->ns->proc_name->attr.allocatable - || tail->expr->symtree->n.sym->ns->proc_name->attr.pointer - || tail->expr->symtree->n.sym->ns->proc_name->attr.proc_pointer); + if (sym && sym->ts.type == BT_CLASS) + b2 = !(sym->ts.u.derived->components->attr.allocatable + || sym->ts.u.derived->components->attr.pointer); + else + b2 = sym && !(sym->attr.allocatable || sym->attr.pointer + || sym->attr.proc_pointer); + b3 = sym && sym->ns && sym->ns->proc_name + && (sym->ns->proc_name->attr.allocatable + || sym->ns->proc_name->attr.pointer + || sym->ns->proc_name->attr.proc_pointer); if (b1 && b2 && !b3) { gfc_error ("Allocate-object at %C is not a nonprocedure pointer " @@ -2616,7 +2638,7 @@ alloc_opt_list: gfc_resolve_expr (tmp); - if (head->expr->ts.type != tmp->ts.type) + if (!gfc_type_compatible (&head->expr->ts, &tmp->ts)) { gfc_error ("Type of entity at %L is type incompatible with " "source-expr at %L", &head->expr->where, &tmp->where); @@ -2657,7 +2679,8 @@ alloc_opt_list: new_st.expr1 = stat; new_st.expr2 = errmsg; new_st.expr3 = source; - new_st.ext.alloc_list = head; + new_st.ext.alloc.list = head; + new_st.ext.alloc.ts = ts; return MATCH_YES; @@ -2754,8 +2777,9 @@ gfc_match_deallocate (void) { gfc_alloc *head, *tail; gfc_expr *stat, *errmsg, *tmp; + gfc_symbol *sym; match m; - bool saw_stat, saw_errmsg; + bool saw_stat, saw_errmsg, b1, b2; head = tail = NULL; stat = errmsg = tmp = NULL; @@ -2783,20 +2807,25 @@ gfc_match_deallocate (void) if (gfc_check_do_variable (tail->expr->symtree)) goto cleanup; - if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym)) + sym = tail->expr->symtree->n.sym; + + if (gfc_pure (NULL) && gfc_impure_variable (sym)) { gfc_error ("Illegal allocate-object at %C for a PURE procedure"); goto cleanup; } /* FIXME: disable the checking on derived types. */ - if (!(tail->expr->ref + b1 = !(tail->expr->ref && (tail->expr->ref->type == REF_COMPONENT - || tail->expr->ref->type == REF_ARRAY)) - && tail->expr->symtree->n.sym - && !(tail->expr->symtree->n.sym->attr.allocatable - || tail->expr->symtree->n.sym->attr.pointer - || tail->expr->symtree->n.sym->attr.proc_pointer)) + || tail->expr->ref->type == REF_ARRAY)); + if (sym && sym->ts.type == BT_CLASS) + b2 = !(sym->ts.u.derived->components->attr.allocatable + || sym->ts.u.derived->components->attr.pointer); + else + b2 = sym && !(sym->attr.allocatable || sym->attr.pointer + || sym->attr.proc_pointer); + if (b1 && b2) { gfc_error ("Allocate-object at %C is not a nonprocedure pointer " "or an allocatable variable"); @@ -2865,7 +2894,7 @@ dealloc_opt_list: new_st.op = EXEC_DEALLOCATE; new_st.expr1 = stat; new_st.expr2 = errmsg; - new_st.ext.alloc_list = head; + new_st.ext.alloc.list = head; return MATCH_YES; @@ -3021,7 +3050,8 @@ gfc_match_call (void) /* If this is a variable of derived-type, it probably starts a type-bound procedure call. */ - if (sym->attr.flavor != FL_PROCEDURE && sym->ts.type == BT_DERIVED) + if (sym->attr.flavor != FL_PROCEDURE + && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)) return match_typebound_call (st); /* If it does not seem to be callable (include functions so that the @@ -3949,10 +3979,7 @@ match_case_eos (void) /* If the case construct doesn't have a case-construct-name, we should have matched the EOS. */ if (!gfc_current_block ()) - { - gfc_error ("Expected the name of the SELECT CASE construct at %C"); - return MATCH_ERROR; - } + return MATCH_NO; gfc_gobble_whitespace (); @@ -3962,7 +3989,7 @@ match_case_eos (void) if (strcmp (name, gfc_current_block ()->name) != 0) { - gfc_error ("Expected case name of '%s' at %C", + gfc_error ("Expected block name '%s' of SELECT construct at %C", gfc_current_block ()->name); return MATCH_ERROR; } @@ -3994,6 +4021,61 @@ gfc_match_select (void) } +/* Match a SELECT TYPE statement. */ + +match +gfc_match_select_type (void) +{ + gfc_expr *expr; + match m; + + m = gfc_match_label (); + if (m == MATCH_ERROR) + return m; + + m = gfc_match (" select type ( %e ", &expr); + if (m != MATCH_YES) + return m; + + /* TODO: Implement ASSOCIATE. */ + m = gfc_match (" => "); + if (m == MATCH_YES) + { + gfc_error ("Associate-name in SELECT TYPE statement at %C " + "is not yet supported"); + return MATCH_ERROR; + } + + m = gfc_match (" )%t"); + if (m != MATCH_YES) + return m; + + /* Check for F03:C811. + TODO: Change error message once ASSOCIATE is implemented. */ + if (expr->expr_type != EXPR_VARIABLE || expr->ref != NULL) + { + gfc_error ("Selector must be a named variable in SELECT TYPE statement " + "at %C"); + return MATCH_ERROR; + } + + /* Check for F03:C813. */ + if (expr->ts.type != BT_CLASS) + { + gfc_error ("Selector shall be polymorphic in SELECT TYPE statement " + "at %C"); + return MATCH_ERROR; + } + + new_st.op = EXEC_SELECT_TYPE; + new_st.expr1 = expr; + + type_selector = expr->symtree->n.sym; + + return MATCH_YES; +} + + /* Match a CASE statement. */ match @@ -4058,13 +4140,142 @@ gfc_match_case (void) return MATCH_YES; syntax: - gfc_error ("Syntax error in CASE-specification at %C"); + gfc_error ("Syntax error in CASE specification at %C"); cleanup: gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */ return MATCH_ERROR; } + +/* Match a TYPE IS statement. */ + +match +gfc_match_type_is (void) +{ + gfc_case *c = NULL; + match m; + char name[GFC_MAX_SYMBOL_LEN]; + + if (gfc_current_state () != COMP_SELECT_TYPE) + { + gfc_error ("Unexpected TYPE IS statement at %C"); + return MATCH_ERROR; + } + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + c = gfc_get_case (); + c->where = gfc_current_locus; + + /* TODO: Once unlimited polymorphism is implemented, we will need to call + match_type_spec here. */ + if (match_derived_type_spec (&c->ts) == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT_TYPE; + new_st.ext.case_list = c; + + /* Create temporary variable. */ + sprintf (name, "tmp$%s", c->ts.u.derived->name); + gfc_get_sym_tree (name, gfc_current_ns, &select_type_tmp, false); + select_type_tmp->n.sym->ts = c->ts; + select_type_tmp->n.sym->attr.referenced = 1; + select_type_tmp->n.sym->attr.pointer = 1; + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in TYPE IS specification at %C"); + +cleanup: + if (c != NULL) + gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ + return MATCH_ERROR; +} + + +/* Match a CLASS IS or CLASS DEFAULT statement. */ + +match +gfc_match_class_is (void) +{ + gfc_case *c = NULL; + match m; + + if (gfc_current_state () != COMP_SELECT_TYPE) + return MATCH_NO; + + if (gfc_match ("% default") == MATCH_YES) + { + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT_TYPE; + c = gfc_get_case (); + c->where = gfc_current_locus; + c->ts.type = BT_UNKNOWN; + new_st.ext.case_list = c; + return MATCH_YES; + } + + m = gfc_match ("% is"); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + c = gfc_get_case (); + c->where = gfc_current_locus; + + if (match_derived_type_spec (&c->ts) == MATCH_ERROR) + goto cleanup; + + if (c->ts.type == BT_DERIVED) + c->ts.type = BT_CLASS; + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT_TYPE; + new_st.ext.case_list = c; + + gfc_error_now ("CLASS IS specification at %C is not yet supported"); + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in CLASS IS specification at %C"); + +cleanup: + if (c != NULL) + gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ + return MATCH_ERROR; +} + + /********************* WHERE subroutines ********************/ /* Match the rest of a simple WHERE statement that follows an IF statement. diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index a53c7f0f8dd..bc1945302c9 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -101,6 +101,9 @@ match gfc_match_equivalence (void); match gfc_match_st_function (void); match gfc_match_case (void); match gfc_match_select (void); +match gfc_match_select_type (void); +match gfc_match_type_is (void); +match gfc_match_class_is (void); match gfc_match_where (gfc_statement *); match gfc_match_elsewhere (void); match gfc_match_forall (gfc_statement *); diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c index f80c9fa6af7..b5e6275bc8d 100644 --- a/gcc/fortran/misc.c +++ b/gcc/fortran/misc.c @@ -71,7 +71,6 @@ gfc_clear_ts (gfc_typespec *ts) ts->kind = 0; ts->u.cl = NULL; ts->interface = NULL; - ts->is_class = 0; /* flag that says if the type is C interoperable */ ts->is_c_interop = 0; /* says what f90 type the C kind interops with */ @@ -131,6 +130,9 @@ gfc_basic_typename (bt type) case BT_DERIVED: p = "DERIVED"; break; + case BT_CLASS: + p = "CLASS"; + break; case BT_PROCEDURE: p = "PROCEDURE"; break; @@ -186,6 +188,10 @@ gfc_typename (gfc_typespec *ts) case BT_DERIVED: sprintf (buffer, "TYPE(%s)", ts->u.derived->name); break; + case BT_CLASS: + sprintf (buffer, "CLASS(%s)", + ts->u.derived->components->ts.u.derived->name); + break; case BT_PROCEDURE: strcpy (buffer, "PROCEDURE"); break; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index ec15d3f8000..1769eada5fe 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -1672,7 +1672,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_PROCEDURE, AB_PROC_POINTER + AB_EXTENSION, AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER } ab_attribute; @@ -1713,6 +1713,7 @@ static const mstring attr_bits[] = 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), minit (NULL, -1) @@ -1860,6 +1861,8 @@ mio_symbol_attribute (symbol_attribute *attr) 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) MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits); if (attr->proc_pointer) @@ -1985,6 +1988,9 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_EXTENSION: attr->extension = 1; break; + case AB_IS_CLASS: + attr->is_class = 1; + break; case AB_PROCEDURE: attr->procedure = 1; break; @@ -2004,6 +2010,7 @@ static const mstring bt_types[] = { minit ("LOGICAL", BT_LOGICAL), minit ("CHARACTER", BT_CHARACTER), minit ("DERIVED", BT_DERIVED), + minit ("CLASS", BT_CLASS), minit ("PROCEDURE", BT_PROCEDURE), minit ("UNKNOWN", BT_UNKNOWN), minit ("VOID", BT_VOID), @@ -2054,7 +2061,7 @@ mio_typespec (gfc_typespec *ts) ts->type = MIO_NAME (bt) (ts->type, bt_types); - if (ts->type != BT_DERIVED) + if (ts->type != BT_DERIVED && ts->type != BT_CLASS) mio_integer (&ts->kind); else mio_symbol_ref (&ts->u.derived); @@ -3566,7 +3573,10 @@ mio_symbol (gfc_symbol *sym) } mio_integer (&(sym->intmod_sym_id)); - + + if (sym->attr.flavor == FL_DERIVED) + mio_integer (&(sym->vindex)); + mio_rparen (); } diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index e6b5dbb1801..13199c91bb0 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -312,6 +312,7 @@ decode_statement (void) match (NULL, gfc_match_block, ST_BLOCK); match (NULL, gfc_match_do, ST_DO); match (NULL, gfc_match_select, ST_SELECT_CASE); + match (NULL, gfc_match_select_type, ST_SELECT_TYPE); /* General statement matching: Instead of testing every possible statement, we eliminate most possibilities by peeking at the @@ -343,6 +344,7 @@ decode_statement (void) match ("case", gfc_match_case, ST_CASE); match ("common", gfc_match_common, ST_COMMON); match ("contains", gfc_match_eos, ST_CONTAINS); + match ("class", gfc_match_class_is, ST_CLASS_IS); break; case 'd': @@ -432,6 +434,7 @@ decode_statement (void) case 't': match ("target", gfc_match_target, ST_ATTR_DECL); match ("type", gfc_match_derived_decl, ST_DERIVED_DECL); + match ("type is", gfc_match_type_is, ST_TYPE_IS); break; case 'u': @@ -936,7 +939,8 @@ next_statement (void) #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \ case ST_IF_BLOCK: case ST_BLOCK: \ - case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \ + case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \ + case ST_OMP_PARALLEL: \ case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \ case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \ case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \ @@ -1360,6 +1364,15 @@ gfc_ascii_statement (gfc_statement st) case ST_SELECT_CASE: p = "SELECT CASE"; break; + case ST_SELECT_TYPE: + p = "SELECT TYPE"; + break; + case ST_TYPE_IS: + p = "TYPE IS"; + break; + case ST_CLASS_IS: + p = "CLASS IS"; + break; case ST_SEQUENCE: p = "SEQUENCE"; break; @@ -2874,6 +2887,83 @@ parse_select_block (void) } +/* Parse a SELECT TYPE construct (F03:R821). */ + +static void +parse_select_type_block (void) +{ + gfc_statement st; + gfc_code *cp; + gfc_state_data s; + + accept_statement (ST_SELECT_TYPE); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_SELECT_TYPE, gfc_new_block); + + /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT + or END SELECT. */ + for (;;) + { + st = next_statement (); + if (st == ST_NONE) + unexpected_eof (); + if (st == ST_END_SELECT) + { + /* Empty SELECT CASE is OK. */ + accept_statement (st); + pop_state (); + return; + } + if (st == ST_TYPE_IS || st == ST_CLASS_IS) + break; + + gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement " + "following SELECT TYPE at %C"); + + reject_statement (); + } + + /* At this point, we're got a nonempty select block. */ + cp = new_level (cp); + *cp = new_st; + + accept_statement (st); + + do + { + st = parse_executable (ST_NONE); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_TYPE_IS: + case ST_CLASS_IS: + cp = new_level (gfc_state_stack->head); + *cp = new_st; + gfc_clear_new_st (); + + accept_statement (st); + /* Fall through */ + + case ST_END_SELECT: + break; + + /* Can't have an executable statement because of + parse_executable(). */ + default: + unexpected_statement (st); + break; + } + } + while (st != ST_END_SELECT); + + pop_state (); + accept_statement (st); +} + + /* Given a symbol, make sure it is not an iteration variable for a DO statement. This subroutine is called when the symbol is seen in a context that causes it to become redefined. If the symbol is an @@ -3395,6 +3485,10 @@ parse_executable (gfc_statement st) parse_select_block (); break; + case ST_SELECT_TYPE: + parse_select_type_block(); + break; + case ST_DO: parse_do_block (); if (check_do_closure () == 1) diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 7239c38da7f..2b926618d28 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -32,7 +32,7 @@ typedef enum COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS, COMP_BLOCK, COMP_IF, COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM, - COMP_OMP_STRUCTURED_BLOCK + COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK } gfc_compile_state; diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index f25de2397bf..c0777c48b85 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1733,7 +1733,9 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, || (sym->attr.dimension && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary, NULL) && !(gfc_matching_procptr_assignment - && sym->attr.flavor == FL_PROCEDURE))) + && sym->attr.flavor == FL_PROCEDURE)) + || (sym->ts.type == BT_CLASS + && sym->ts.u.derived->components->attr.dimension)) { /* In EQUIVALENCE, we don't know yet whether we are seeing an array, character variable or array of character @@ -1767,7 +1769,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED) gfc_set_default_type (sym, 0, sym->ns); - if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES) + if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS) + || gfc_match_char ('%') != MATCH_YES) goto check_substring; sym = sym->ts.u.derived; @@ -1865,8 +1868,21 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (m != MATCH_YES) return m; } + else if (component->ts.type == BT_CLASS + && component->ts.u.derived->components->as != NULL + && !component->attr.proc_pointer) + { + tail = extend_ref (primary, tail); + tail->type = REF_ARRAY; - if (component->ts.type != BT_DERIVED + m = gfc_match_array_ref (&tail->u.ar, + component->ts.u.derived->components->as, + equiv_flag); + if (m != MATCH_YES) + return m; + } + + if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS) || gfc_match_char ('%') != MATCH_YES) break; @@ -1875,7 +1891,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, check_substring: unknown = false; - if (primary->ts.type == BT_UNKNOWN) + if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED) { if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER) { @@ -1943,23 +1959,35 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) int dimension, pointer, allocatable, target; symbol_attribute attr; gfc_ref *ref; + gfc_symbol *sym; + gfc_component *comp; if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION) gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable"); ref = expr->ref; - attr = expr->symtree->n.sym->attr; + sym = expr->symtree->n.sym; + attr = sym->attr; - dimension = attr.dimension; - pointer = attr.pointer; - allocatable = attr.allocatable; + if (sym->ts.type == BT_CLASS) + { + dimension = sym->ts.u.derived->components->attr.dimension; + pointer = sym->ts.u.derived->components->attr.pointer; + allocatable = sym->ts.u.derived->components->attr.allocatable; + } + else + { + dimension = attr.dimension; + pointer = attr.pointer; + allocatable = attr.allocatable; + } target = attr.target; if (pointer || attr.proc_pointer) target = 1; if (ts != NULL && expr->ts.type == BT_UNKNOWN) - *ts = expr->symtree->n.sym->ts; + *ts = sym->ts; for (; ref; ref = ref->next) switch (ref->type) @@ -1988,10 +2016,11 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) break; case REF_COMPONENT: - attr = ref->u.c.component->attr; + comp = ref->u.c.component; + attr = comp->attr; if (ts != NULL) { - *ts = ref->u.c.component->ts; + *ts = comp->ts; /* Don't set the string length if a substring reference follows. */ if (ts->type == BT_CHARACTER @@ -1999,8 +2028,16 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) ts->u.cl = NULL; } - pointer = ref->u.c.component->attr.pointer; - allocatable = ref->u.c.component->attr.allocatable; + if (comp->ts.type == BT_CLASS) + { + pointer = comp->ts.u.derived->components->attr.pointer; + allocatable = comp->ts.u.derived->components->attr.allocatable; + } + else + { + pointer = comp->attr.pointer; + allocatable = comp->attr.allocatable; + } if (pointer || attr.proc_pointer) target = 1; @@ -2037,7 +2074,16 @@ gfc_expr_attr (gfc_expr *e) gfc_clear_attr (&attr); if (e->value.function.esym != NULL) - attr = e->value.function.esym->result->attr; + { + gfc_symbol *sym = e->value.function.esym->result; + attr = sym->attr; + if (sym->ts.type == BT_CLASS) + { + attr.dimension = sym->ts.u.derived->components->attr.dimension; + attr.pointer = sym->ts.u.derived->components->attr.pointer; + attr.allocatable = sym->ts.u.derived->components->attr.allocatable; + } + } else attr = gfc_variable_attr (e, NULL); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 3eec50e5373..445753eca82 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -879,7 +879,10 @@ resolve_structure_cons (gfc_expr *expr) if (cons->expr->expr_type == EXPR_NULL && !(comp->attr.pointer || comp->attr.allocatable - || comp->attr.proc_pointer)) + || comp->attr.proc_pointer + || (comp->ts.type == BT_CLASS + && (comp->ts.u.derived->components->attr.pointer + || comp->ts.u.derived->components->attr.allocatable)))) { t = FAILURE; gfc_error ("The NULL in the derived type constructor at %L is " @@ -3931,7 +3934,10 @@ find_array_spec (gfc_expr *e) gfc_symbol *derived; gfc_ref *ref; - as = e->symtree->n.sym->as; + if (e->symtree->n.sym->ts.type == BT_CLASS) + as = e->symtree->n.sym->ts.u.derived->components->as; + else + as = e->symtree->n.sym->as; derived = NULL; for (ref = e->ref; ref; ref = ref->next) @@ -4844,7 +4850,7 @@ check_typebound_baseobject (gfc_expr* e) if (!base) return FAILURE; - gcc_assert (base->ts.type == BT_DERIVED); + gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS); if (base->ts.u.derived->attr.abstract) { gfc_error ("Base object for type-bound procedure call at %L is of" @@ -5051,7 +5057,10 @@ static gfc_try resolve_ppc_call (gfc_code* c) { gfc_component *comp; - gcc_assert (gfc_is_proc_ptr_comp (c->expr1, &comp)); + bool b; + + b = gfc_is_proc_ptr_comp (c->expr1, &comp); + gcc_assert (b); c->resolved_sym = c->expr1->symtree->n.sym; c->expr1->expr_type = EXPR_VARIABLE; @@ -5083,7 +5092,10 @@ static gfc_try resolve_expr_ppc (gfc_expr* e) { gfc_component *comp; - gcc_assert (gfc_is_proc_ptr_comp (e, &comp)); + bool b; + + b = gfc_is_proc_ptr_comp (e, &comp); + gcc_assert (b); /* Convert to EXPR_FUNCTION. */ e->expr_type = EXPR_FUNCTION; @@ -5462,6 +5474,8 @@ resolve_deallocate_expr (gfc_expr *e) symbol_attribute attr; int allocatable, pointer, check_intent_in; gfc_ref *ref; + gfc_symbol *sym; + gfc_component *c; /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ check_intent_in = 1; @@ -5472,8 +5486,18 @@ resolve_deallocate_expr (gfc_expr *e) if (e->expr_type != EXPR_VARIABLE) goto bad; - allocatable = e->symtree->n.sym->attr.allocatable; - pointer = e->symtree->n.sym->attr.pointer; + sym = e->symtree->n.sym; + + if (sym->ts.type == BT_CLASS) + { + allocatable = sym->ts.u.derived->components->attr.allocatable; + pointer = sym->ts.u.derived->components->attr.pointer; + } + else + { + allocatable = sym->attr.allocatable; + pointer = sym->attr.pointer; + } for (ref = e->ref; ref; ref = ref->next) { if (pointer) @@ -5487,9 +5511,17 @@ resolve_deallocate_expr (gfc_expr *e) break; case REF_COMPONENT: - allocatable = (ref->u.c.component->as != NULL - && ref->u.c.component->as->type == AS_DEFERRED); - pointer = ref->u.c.component->attr.pointer; + c = ref->u.c.component; + if (c->ts.type == BT_CLASS) + { + allocatable = c->ts.u.derived->components->attr.allocatable; + pointer = c->ts.u.derived->components->attr.pointer; + } + else + { + allocatable = c->attr.allocatable; + pointer = c->attr.pointer; + } break; case REF_SUBSTRING: @@ -5507,14 +5539,19 @@ resolve_deallocate_expr (gfc_expr *e) &e->where); } - if (check_intent_in - && e->symtree->n.sym->attr.intent == INTENT_IN) + if (check_intent_in && sym->attr.intent == INTENT_IN) { gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L", - e->symtree->n.sym->name, &e->where); + sym->name, &e->where); return FAILURE; } + if (e->ts.type == BT_CLASS) + { + /* Only deallocate the DATA component. */ + gfc_add_component_ref (e, "$data"); + } + return SUCCESS; } @@ -5541,8 +5578,8 @@ gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e) derived types with default initializers, and derived types with allocatable components that need nullification.) */ -static gfc_expr * -expr_to_initialize (gfc_expr *e) +gfc_expr * +gfc_expr_to_initialize (gfc_expr *e) { gfc_expr *result; gfc_ref *ref; @@ -5579,9 +5616,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) gfc_ref *ref, *ref2; gfc_array_ref *ar; gfc_code *init_st; - gfc_expr *init_e; gfc_symbol *sym; gfc_alloc *a; + gfc_component *c; /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ check_intent_in = 1; @@ -5593,6 +5630,8 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) pointer, the next-to-last reference must be a pointer. */ ref2 = NULL; + if (e->symtree) + sym = e->symtree->n.sym; if (e->expr_type != EXPR_VARIABLE) { @@ -5603,9 +5642,18 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) } else { - allocatable = e->symtree->n.sym->attr.allocatable; - pointer = e->symtree->n.sym->attr.pointer; - dimension = e->symtree->n.sym->attr.dimension; + if (sym->ts.type == BT_CLASS) + { + allocatable = sym->ts.u.derived->components->attr.allocatable; + pointer = sym->ts.u.derived->components->attr.pointer; + dimension = sym->ts.u.derived->components->attr.dimension; + } + else + { + allocatable = sym->attr.allocatable; + pointer = sym->attr.pointer; + dimension = sym->attr.dimension; + } for (ref = e->ref; ref; ref2 = ref, ref = ref->next) { @@ -5620,11 +5668,19 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) break; case REF_COMPONENT: - allocatable = (ref->u.c.component->as != NULL - && ref->u.c.component->as->type == AS_DEFERRED); - - pointer = ref->u.c.component->attr.pointer; - dimension = ref->u.c.component->attr.dimension; + c = ref->u.c.component; + if (c->ts.type == BT_CLASS) + { + allocatable = c->ts.u.derived->components->attr.allocatable; + pointer = c->ts.u.derived->components->attr.pointer; + dimension = c->ts.u.derived->components->attr.dimension; + } + else + { + allocatable = c->attr.allocatable; + pointer = c->attr.pointer; + dimension = c->attr.dimension; + } break; case REF_SUBSTRING: @@ -5642,24 +5698,46 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) return FAILURE; } - if (check_intent_in - && e->symtree->n.sym->attr.intent == INTENT_IN) + if (check_intent_in && sym->attr.intent == INTENT_IN) { gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L", - e->symtree->n.sym->name, &e->where); + sym->name, &e->where); return FAILURE; } - /* Add default initializer for those derived types that need them. */ - if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts))) + if (e->ts.type == BT_CLASS) { + /* Initialize VINDEX for CLASS objects. */ init_st = gfc_get_code (); init_st->loc = code->loc; - init_st->op = EXEC_INIT_ASSIGN; - init_st->expr1 = expr_to_initialize (e); - init_st->expr2 = init_e; + init_st->expr1 = gfc_expr_to_initialize (e); + init_st->op = EXEC_ASSIGN; + gfc_add_component_ref (init_st->expr1, "$vindex"); + if (code->expr3 && code->expr3->ts.type == BT_CLASS) + { + /* vindex must be determined at run time. */ + init_st->expr2 = gfc_copy_expr (code->expr3); + gfc_add_component_ref (init_st->expr2, "$vindex"); + } + else + { + /* vindex is fixed at compile time. */ + int vindex; + if (code->expr3) + vindex = code->expr3->ts.u.derived->vindex; + else if (code->ext.alloc.ts.type == BT_DERIVED) + vindex = code->ext.alloc.ts.u.derived->vindex; + else if (e->ts.type == BT_CLASS) + vindex = e->ts.u.derived->components->ts.u.derived->vindex; + else + vindex = e->ts.u.derived->vindex; + init_st->expr2 = gfc_int_expr (vindex); + } + init_st->expr2->where = init_st->expr1->where = init_st->loc; init_st->next = code->next; code->next = init_st; + /* Only allocate the DATA component. */ + gfc_add_component_ref (e, "$data"); } if (pointer || dimension == 0) @@ -5706,7 +5784,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) check_symbols: - for (a = code->ext.alloc_list; a; a = a->next) + for (a = code->ext.alloc.list; a; a = a->next) { sym = a->expr->symtree->n.sym; @@ -5758,7 +5836,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) gfc_error ("Stat-variable at %L must be a scalar INTEGER " "variable", &stat->where); - for (p = code->ext.alloc_list; p; p = p->next) + for (p = code->ext.alloc.list; p; p = p->next) if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name) gfc_error ("Stat-variable at %L shall not be %sd within " "the same %s statement", &stat->where, fcn, fcn); @@ -5787,7 +5865,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER " "variable", &errmsg->where); - for (p = code->ext.alloc_list; p; p = p->next) + for (p = code->ext.alloc.list; p; p = p->next) if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name) gfc_error ("Errmsg-variable at %L shall not be %sd within " "the same %s statement", &errmsg->where, fcn, fcn); @@ -5795,7 +5873,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) /* Check that an allocate-object appears only once in the statement. FIXME: Checking derived types is disabled. */ - for (p = code->ext.alloc_list; p; p = p->next) + for (p = code->ext.alloc.list; p; p = p->next) { pe = p->expr; if ((pe->ref && pe->ref->type != REF_COMPONENT) @@ -5815,12 +5893,12 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) if (strcmp (fcn, "ALLOCATE") == 0) { - for (a = code->ext.alloc_list; a; a = a->next) + for (a = code->ext.alloc.list; a; a = a->next) resolve_allocate_expr (a->expr, code); } else { - for (a = code->ext.alloc_list; a; a = a->next) + for (a = code->ext.alloc.list; a; a = a->next) resolve_deallocate_expr (a->expr); } } @@ -6346,6 +6424,116 @@ resolve_select (gfc_code *code) } +/* Check if a derived type is extensible. */ + +bool +gfc_type_is_extensible (gfc_symbol *sym) +{ + return !(sym->attr.is_bind_c || sym->attr.sequence); +} + + +/* Resolve a SELECT TYPE statement. */ + +static void +resolve_select_type (gfc_code *code) +{ + gfc_symbol *selector_type; + gfc_code *body, *new_st; + gfc_case *c, *default_case; + gfc_symtree *st; + char name[GFC_MAX_SYMBOL_LEN]; + + 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) + { + c = body->ext.case_list; + + /* Check F03:C815. */ + if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && !gfc_type_is_extensible (c->ts.u.derived)) + { + gfc_error ("Derived type '%s' at %L must be extensible", + c->ts.u.derived->name, &c->where); + continue; + } + + /* Check F03:C816. */ + if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && !gfc_type_is_extension_of (selector_type, c->ts.u.derived)) + { + gfc_error ("Derived type '%s' at %L must be an extension of '%s'", + c->ts.u.derived->name, &c->where, selector_type->name); + continue; + } + + /* Intercept the DEFAULT case. */ + 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); + else + default_case = c; + continue; + } + } + + /* Transform to EXEC_SELECT. */ + code->op = EXEC_SELECT; + gfc_add_component_ref (code->expr1, "$vindex"); + + /* 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) + continue; + /* Assign temporary to selector. */ + sprintf (name, "tmp$%s", c->ts.u.derived->name); + st = gfc_find_symtree (code->expr1->symtree->n.sym->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"); + new_st->next = body->next; + body->next = new_st; + } + + /* Eliminate dead blocks. */ + for (body = code; body && body->block; body = body->block) + { + if (body->block->ext.case_list->unreachable) + { + /* 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); + } + } + + resolve_select (code); + +} + + /* Resolve a transfer statement. This is making sure that: -- a derived type being transferred has only non-pointer components -- a derived type being transferred doesn't have private components, unless @@ -6911,6 +7099,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) break; case EXEC_SELECT: + case EXEC_SELECT_TYPE: case EXEC_FORALL: case EXEC_DO: case EXEC_DO_WHILE: @@ -7102,6 +7291,40 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) } +/* Check an assignment to a CLASS object (pointer or ordinary assignment). */ + +static void +resolve_class_assign (gfc_code *code) +{ + gfc_code *assign_code = gfc_get_code (); + + /* Insert an additional assignment which sets the vindex. */ + assign_code->next = code->next; + code->next = assign_code; + assign_code->op = EXEC_ASSIGN; + assign_code->expr1 = gfc_copy_expr (code->expr1); + gfc_add_component_ref (assign_code->expr1, "$vindex"); + if (code->expr2->ts.type == BT_DERIVED) + /* vindex is constant, determined at compile time. */ + assign_code->expr2 = gfc_int_expr (code->expr2->ts.u.derived->vindex); + else if (code->expr2->ts.type == BT_CLASS) + { + /* vindex must be determined at run time. */ + assign_code->expr2 = gfc_copy_expr (code->expr2); + gfc_add_component_ref (assign_code->expr2, "$vindex"); + } + else if (code->expr2->expr_type == EXPR_NULL) + assign_code->expr2 = gfc_int_expr (0); + else + gcc_unreachable (); + + /* Modify the actual pointer assignment. */ + gfc_add_component_ref (code->expr1, "$data"); + if (code->expr2->ts.type == BT_CLASS) + gfc_add_component_ref (code->expr2, "$data"); +} + + /* Given a block of code, recursively resolve everything pointed to by this code block. */ @@ -7224,6 +7447,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns) if (t == FAILURE) break; + if (code->expr1->ts.type == BT_CLASS) + resolve_class_assign (code); + if (resolve_ordinary_assign (code, ns)) { if (code->op == EXEC_COMPCALL) @@ -7252,7 +7478,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) if (t == FAILURE) break; + if (code->expr1->ts.type == BT_CLASS) + resolve_class_assign (code); + gfc_check_pointer_assign (code->expr1, code->expr2); + break; case EXEC_ARITHMETIC_IF: @@ -7295,6 +7525,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns) resolve_select (code); break; + case EXEC_SELECT_TYPE: + resolve_select_type (code); + break; + case EXEC_BLOCK: gfc_resolve (code->ext.ns); break; @@ -8023,8 +8257,8 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) } else { - if (!mp_flag && !sym->attr.allocatable - && !sym->attr.pointer && !sym->attr.dummy) + if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer + && !sym->attr.dummy && sym->ts.type != BT_CLASS) { gfc_error ("Array '%s' at %L cannot have a deferred shape", sym->name, &sym->declared_at); @@ -8035,22 +8269,13 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) } -/* Check if a derived type is extensible. */ - -static bool -type_is_extensible (gfc_symbol *sym) -{ - return !(sym->attr.is_bind_c || sym->attr.sequence); -} - - /* Additional checks for symbols with flavor variable and derived type. To be called from resolve_fl_variable. */ static gfc_try resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) { - gcc_assert (sym->ts.type == BT_DERIVED); + gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS); /* Check to see if a derived type is blocked from being host associated by the presence of another class I symbol in the same @@ -8092,10 +8317,10 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) return FAILURE; } - if (sym->ts.is_class) + if (sym->ts.type == BT_CLASS) { /* C502. */ - if (!type_is_extensible (sym->ts.u.derived)) + 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); @@ -8103,7 +8328,9 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) } /* C509. */ - if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer)) + if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer + || sym->ts.u.derived->components->attr.allocatable + || sym->ts.u.derived->components->attr.pointer)) { gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable " "or pointer", sym->name, &sym->declared_at); @@ -8244,7 +8471,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) } no_init_error: - if (sym->ts.type == BT_DERIVED) + if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) return resolve_fl_variable_derived (sym, no_init_flag); return SUCCESS; @@ -8890,6 +9117,9 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, sym1 = t1->specific->u.specific->n.sym; sym2 = t2->specific->u.specific->n.sym; + if (sym1 == sym2) + return SUCCESS; + /* Both must be SUBROUTINEs or both must be FUNCTIONs. */ if (sym1->attr.subroutine != sym2->attr.subroutine || sym1->attr.function != sym2->attr.function) @@ -9283,21 +9513,22 @@ resolve_typebound_procedure (gfc_symtree* stree) /* Now check that the argument-type matches. */ gcc_assert (me_arg); - if (me_arg->ts.type != BT_DERIVED - || me_arg->ts.u.derived != resolve_bindings_derived) + if (me_arg->ts.type != BT_CLASS) { - gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" - " the derived-type '%s'", me_arg->name, proc->name, - me_arg->name, &where, resolve_bindings_derived->name); + gfc_error ("Non-polymorphic passed-object dummy argument of '%s'" + " at %L", proc->name, &where); goto error; } - if (!me_arg->ts.is_class) + if (me_arg->ts.u.derived->components->ts.u.derived + != resolve_bindings_derived) { - gfc_error ("Non-polymorphic passed-object dummy argument of '%s'" - " at %L", proc->name, &where); + gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" + " the derived-type '%s'", me_arg->name, proc->name, + me_arg->name, &where, resolve_bindings_derived->name); goto error; } + } /* If we are extending some type, check that we don't override a procedure @@ -9475,7 +9706,7 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; /* An ABSTRACT type must be extensible. */ - if (sym->attr.abstract && !type_is_extensible (sym)) + if (sym->attr.abstract && !gfc_type_is_extensible (sym)) { gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT", sym->name, &sym->declared_at); @@ -9611,8 +9842,10 @@ resolve_fl_derived (gfc_symbol *sym) /* Now check that the argument-type matches. */ gcc_assert (me_arg); - if (me_arg->ts.type != BT_DERIVED - || me_arg->ts.u.derived != sym) + if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS) + || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym) + || (me_arg->ts.type == BT_CLASS + && me_arg->ts.u.derived->components->ts.u.derived != sym)) { gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" " the derived type '%s'", me_arg->name, c->name, @@ -9649,9 +9882,9 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } - if (type_is_extensible (sym) && !me_arg->ts.is_class) + if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS) gfc_error ("Non-polymorphic passed-object dummy argument of '%s'" - " at %L", c->name, &c->loc); + " at %L", c->name, &c->loc); } @@ -9720,8 +9953,9 @@ resolve_fl_derived (gfc_symbol *sym) } /* C437. */ - if (c->ts.type == BT_DERIVED && c->ts.is_class - && !(c->attr.pointer || c->attr.allocatable)) + if (c->ts.type == BT_CLASS + && !(c->ts.u.derived->components->attr.pointer + || c->ts.u.derived->components->attr.allocatable)) { gfc_error ("Component '%s' with CLASS at %L must be allocatable " "or pointer", c->name, &c->loc); diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index c3c640adc93..f1765e6ed7c 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -122,6 +122,7 @@ gfc_free_statement (gfc_code *p) break; case EXEC_SELECT: + case EXEC_SELECT_TYPE: if (p->ext.case_list) gfc_free_case_list (p->ext.case_list); break; @@ -132,7 +133,7 @@ gfc_free_statement (gfc_code *p) case EXEC_ALLOCATE: case EXEC_DEALLOCATE: - gfc_free_alloc_list (p->ext.alloc_list); + gfc_free_alloc_list (p->ext.alloc.list); break; case EXEC_OPEN: diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index f6ce3cfce82..39285b16fea 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2644,6 +2644,13 @@ gfc_get_ha_sym_tree (const char *name, gfc_symtree **result) int i; i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st); + + /* Special case: If we're in a SELECT TYPE block, + replace the selector variable by a temporary. */ + if (gfc_current_state () == COMP_SELECT_TYPE + && st && st->n.sym == type_selector) + st = select_type_tmp; + if (st != NULL) { save_symbol_data (st->n.sym); @@ -4534,6 +4541,34 @@ gfc_get_derived_super_type (gfc_symbol* derived) } +/* Get the ultimate super-type of a given derived type. */ + +gfc_symbol* +gfc_get_ultimate_derived_super_type (gfc_symbol* derived) +{ + if (!derived->attr.extension) + return NULL; + + derived = gfc_get_derived_super_type (derived); + + if (derived->attr.extension) + return gfc_get_ultimate_derived_super_type (derived); + else + return derived; +} + + +/* Check if a derived type t2 is an extension of (or equal to) a type t1. */ + +bool +gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2) +{ + while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension) + t2 = gfc_get_derived_super_type (t2); + return gfc_compare_derived_types (t1, t2); +} + + /* Check if two typespecs are type compatible (F03:5.1.1.2): If ts1 is nonpolymorphic, ts2 must be the same type. If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */ @@ -4541,19 +4576,16 @@ gfc_get_derived_super_type (gfc_symbol* derived) bool gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) { - if (ts1->type == BT_DERIVED && ts2->type == BT_DERIVED) + if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS) + && (ts2->type == BT_DERIVED || ts2->type == BT_CLASS)) { - gfc_symbol *t0, *t; - if (ts1->is_class) - { - t0 = ts1->u.derived; - t = ts2->u.derived; - while (t0 != t && t->attr.extension) - t = gfc_get_derived_super_type (t); - return (t0 == t); - } + if (ts1->type == BT_CLASS) + return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, + ts2->u.derived); + else if (ts2->type != BT_CLASS) + return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); else - return (ts1->u.derived == ts2->u.derived); + return 0; } else return (ts1->type == ts2->type); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 31c59c6ee84..0c00d322ae7 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5873,7 +5873,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_add_expr_to_block (&fnblock, tmp); } - if (c->attr.allocatable) + if (c->attr.allocatable && c->attr.dimension) { comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); @@ -5885,7 +5885,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, case NULLIFY_ALLOC_COMP: if (c->attr.pointer) continue; - else if (c->attr.allocatable) + else if (c->attr.allocatable && c->attr.dimension) { comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); @@ -6072,7 +6072,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) gfc_add_expr_to_block (&fnblock, tmp); } - if (sym->attr.allocatable && !sym->attr.save && !sym->attr.result) + if (sym->attr.allocatable && sym->attr.dimension + && !sym->attr.save && !sym->attr.result) { tmp = gfc_trans_dealloc_allocated (sym->backend_decl); gfc_add_expr_to_block (&fnblock, tmp); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b3642c2232c..eb741f8231f 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -482,7 +482,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) se->string_length = tmp; } - if ((c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER) + if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0 + && c->ts.type != BT_CHARACTER) || c->attr.proc_pointer) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); @@ -510,8 +511,12 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref) if (dt->attr.extension && dt->components) { + if (dt->attr.is_class) + cmp = dt->components; + else + cmp = dt->components->next; /* Return if the component is not in the parent type. */ - for (cmp = dt->components->next; cmp; cmp = cmp->next) + for (; cmp; cmp = cmp->next) if (strcmp (c->name, cmp->name) == 0) return; @@ -2641,6 +2646,49 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, parmse.string_length = build_int_cst (gfc_charlen_type_node, 0); } } + else if (fsym && fsym->ts.type == BT_CLASS + && e->ts.type == BT_DERIVED) + { + tree data; + tree vindex; + + /* 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); + + /* Set the vindex. */ + tmp = build_int_cst (TREE_TYPE (vindex), + e->ts.u.derived->vindex); + gfc_add_modify (&parmse.pre, vindex, 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); + } else if (se->ss && se->ss->useflags) { /* An elemental function inside a scalarized loop. */ @@ -3607,6 +3655,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, switch (ts->type) { case BT_DERIVED: + case BT_CLASS: gfc_init_se (&se, NULL); gfc_conv_structure (&se, expr, 1); return se.expr; @@ -3771,6 +3820,13 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_add_block_to_block (&block, &se.post); } } + else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL) + { + /* NULL initialization for CLASS components. */ + tmp = gfc_trans_structure_assign (dest, + gfc_default_initializer (&cm->ts)); + gfc_add_expr_to_block (&block, tmp); + } else if (cm->attr.dimension) { if (cm->attr.allocatable && expr->expr_type == EXPR_NULL) @@ -3966,12 +4022,26 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) if (!c->expr || cm->attr.allocatable) continue; - val = gfc_conv_initializer (c->expr, &cm->ts, - TREE_TYPE (cm->backend_decl), cm->attr.dimension, - cm->attr.pointer || cm->attr.proc_pointer); + if (cm->ts.type == BT_CLASS) + { + 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); + + /* Append it to the constructor list. */ + CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl, + val); + } + else + { + val = gfc_conv_initializer (c->expr, &cm->ts, + TREE_TYPE (cm->backend_decl), cm->attr.dimension, + cm->attr.pointer || cm->attr.proc_pointer); - /* Append it to the constructor list. */ - CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + /* Append it to the constructor list. */ + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + } } se->expr = build_constructor (type, v); if (init) diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index b9e5b865b19..b00cebaf0c7 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -4700,6 +4700,56 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) } +/* Generate code for the SAME_TYPE_AS intrinsic. + Generate inline code that directly checks the vindices. */ + +static void +gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) +{ + gfc_expr *a, *b; + gfc_se se1, se2; + tree tmp; + + gfc_init_se (&se1, NULL); + gfc_init_se (&se2, NULL); + + a = expr->value.function.actual->expr; + b = expr->value.function.actual->next->expr; + + if (a->ts.type == BT_CLASS) + gfc_add_component_ref (a, "$vindex"); + else if (a->ts.type == BT_DERIVED) + a = gfc_int_expr (a->ts.u.derived->vindex); + + if (b->ts.type == BT_CLASS) + gfc_add_component_ref (b, "$vindex"); + else if (b->ts.type == BT_DERIVED) + b = gfc_int_expr (b->ts.u.derived->vindex); + + gfc_conv_expr (&se1, a); + gfc_conv_expr (&se2, b); + + tmp = fold_build2 (EQ_EXPR, boolean_type_node, + se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr)); + se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); +} + + +/* 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 @@ -5108,6 +5158,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_associated(se, expr); break; + case GFC_ISYM_SAME_TYPE_AS: + 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; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 25a5b3b4ede..9d3197d11bc 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -3992,7 +3992,7 @@ tree gfc_trans_allocate (gfc_code * code) { gfc_alloc *al; - gfc_expr *expr; + gfc_expr *expr, *init_e, *rhs; gfc_se se; tree tmp; tree parm; @@ -4001,7 +4001,7 @@ gfc_trans_allocate (gfc_code * code) tree error_label; stmtblock_t block; - if (!code->ext.alloc_list) + if (!code->ext.alloc.list) return NULL_TREE; pstat = stat = error_label = tmp = NULL_TREE; @@ -4020,7 +4020,7 @@ gfc_trans_allocate (gfc_code * code) TREE_USED (error_label) = 1; } - for (al = code->ext.alloc_list; al != NULL; al = al->next) + for (al = code->ext.alloc.list; al != NULL; al = al->next) { expr = al->expr; @@ -4034,7 +4034,24 @@ gfc_trans_allocate (gfc_code * code) if (!gfc_array_allocate (&se, expr, pstat)) { /* A scalar or derived type. */ - tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); + + /* Determine allocate size. */ + if (code->expr3 && code->expr3->ts.type == BT_CLASS) + { + gfc_typespec *ts; + /* TODO: Size must be determined at run time, since it must equal + the size of the dynamic type of SOURCE, not the declared type. */ + gfc_warning ("Dynamic size allocation at %L not supported yet, " + "using size of declared type", &code->loc); + ts = &code->expr3->ts.u.derived->components->ts; + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts)); + } + else if (code->expr3 && code->expr3->ts.type != BT_CLASS) + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); + else if (code->ext.alloc.ts.type != BT_UNKNOWN) + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); + else + tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE) tmp = se.string_length; @@ -4065,6 +4082,23 @@ gfc_trans_allocate (gfc_code * code) tmp = gfc_finish_block (&se.pre); gfc_add_expr_to_block (&block, tmp); + + /* Initialization via SOURCE block. */ + if (code->expr3) + { + rhs = gfc_copy_expr (code->expr3); + if (rhs->ts.type == BT_CLASS) + gfc_add_component_ref (rhs, "$data"); + tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), rhs, false); + gfc_add_expr_to_block (&block, tmp); + } + /* Add default initializer for those derived types that need them. */ + else if (expr->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&expr->ts))) + { + tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), init_e, true); + gfc_add_expr_to_block (&block, tmp); + } + } /* STAT block. */ @@ -4111,44 +4145,6 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&block, tmp); } - /* SOURCE block. Note, by C631, we know that code->ext.alloc_list - has a single entity. */ - if (code->expr3) - { - gfc_ref *ref; - gfc_array_ref *ar; - int n; - - /* If there is a terminating array reference, this is converted - to a full array, so that gfc_trans_assignment can scalarize the - expression for the source. */ - for (ref = code->ext.alloc_list->expr->ref; ref; ref = ref->next) - { - if (ref->next == NULL) - { - if (ref->type != REF_ARRAY) - break; - - ref->u.ar.type = AR_FULL; - ar = &ref->u.ar; - ar->dimen = ar->as->rank; - for (n = 0; n < ar->dimen; n++) - { - ar->dimen_type[n] = DIMEN_RANGE; - gfc_free_expr (ar->start[n]); - gfc_free_expr (ar->end[n]); - gfc_free_expr (ar->stride[n]); - ar->start[n] = NULL; - ar->end[n] = NULL; - ar->stride[n] = NULL; - } - } - } - - tmp = gfc_trans_assignment (code->ext.alloc_list->expr, code->expr3, false); - gfc_add_expr_to_block (&block, tmp); - } - return gfc_finish_block (&block); } @@ -4186,7 +4182,7 @@ gfc_trans_deallocate (gfc_code *code) gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0)); } - for (al = code->ext.alloc_list; al != NULL; al = al->next) + for (al = code->ext.alloc.list; al != NULL; al = al->next) { expr = al->expr; gcc_assert (expr->expr_type == EXPR_VARIABLE); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 454a155c1d3..9096ad40849 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1029,6 +1029,7 @@ gfc_typenode_for_spec (gfc_typespec * spec) break; case BT_DERIVED: + case BT_CLASS: basetype = gfc_get_derived_type (spec->u.derived); /* If we're dealing with either C_PTR or C_FUNPTR, we modified the @@ -2063,7 +2064,7 @@ gfc_get_derived_type (gfc_symbol * derived) will be built and so we can return the type. */ for (c = derived->components; c; c = c->next) { - if (c->ts.type != BT_DERIVED) + if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS) continue; if ((!c->attr.pointer && !c->attr.proc_pointer) @@ -2098,7 +2099,7 @@ gfc_get_derived_type (gfc_symbol * derived) { if (c->attr.proc_pointer) field_type = gfc_get_ppc_type (c); - else if (c->ts.type == BT_DERIVED) + else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) field_type = c->ts.u.derived->backend_decl; else { @@ -2134,7 +2135,8 @@ gfc_get_derived_type (gfc_symbol * derived) PACKED_STATIC, !c->attr.target); } - else if (c->attr.pointer && !c->attr.proc_pointer) + else if ((c->attr.pointer || c->attr.allocatable) + && !c->attr.proc_pointer) field_type = build_pointer_type (field_type); field = gfc_add_field_to_struct (&fieldlist, typenode, diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index f53f75e3674..09b424c378f 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1173,6 +1173,13 @@ gfc_trans_code (gfc_code * code) res = gfc_trans_select (code); break; + case EXEC_SELECT_TYPE: + /* Do nothing. SELECT TYPE statements should be transformed into + an ordinary SELECT CASE at resolution stage. + TODO: Add an error message here once this is done. */ + res = NULL_TREE; + break; + case EXEC_FLUSH: res = gfc_trans_flush (code); break; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 61d402aebac..1a98272bc4c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,53 @@ +2009-09-30 Janus Weil <janus@gcc.gnu.org> + + * gfortran.dg/same_type_as_1.f03: New test. + * gfortran.dg/same_type_as_2.f03: Ditto. + +2009-09-30 Janus Weil <janus@gcc.gnu.org> + + * gfortran.dg/select_type_1.f03: Extended. + * gfortran.dg/select_type_3.f03: New test. + +2009-09-30 Janus Weil <janus@gcc.gnu.org> + + * gfortran.dg/class_allocate_1.f03: New test. + +2009-09-30 Janus Weil <janus@gcc.gnu.org> + + PR fortran/40996 + * gfortran.dg/allocatable_scalar_3.f90: New test. + * gfortran.dg/select_type_2.f03: Ditto. + * gfortran.dg/typebound_proc_5.f03: Changed error messages. + +2009-09-30 Janus Weil <janus@gcc.gnu.org> + + * gfortran.dg/block_name_2.f90: Modified error message. + * gfortran.dg/select_6.f90: Ditto. + * gfortran.dg/select_type_1.f03: New test. + +2009-09-30 Janus Weil <janus@gcc.gnu.org> + + * gfortran.dg/allocate_derived_1.f90: Remove -w option. + * gfortran.dg/class_1.f03: Ditto. + * gfortran.dg/class_2.f03: Ditto. + * gfortran.dg/proc_ptr_comp_pass_1.f90: Ditto. + * gfortran.dg/proc_ptr_comp_pass_2.f90: Ditto. + * gfortran.dg/proc_ptr_comp_pass_3.f90: Ditto. + * gfortran.dg/typebound_call_10.f03: Ditto. + * gfortran.dg/typebound_call_2.f03: Ditto. + * gfortran.dg/typebound_call_3.f03: Ditto. + * gfortran.dg/typebound_call_4.f03: Ditto. + * gfortran.dg/typebound_call_9.f03: Ditto. + * gfortran.dg/typebound_generic_3.f03: Ditto. + * gfortran.dg/typebound_generic_4.f03: Ditto. + * gfortran.dg/typebound_operator_1.f03: Ditto. + * gfortran.dg/typebound_operator_2.f03: Ditto. + * gfortran.dg/typebound_operator_3.f03: Ditto. + * gfortran.dg/typebound_operator_4.f03: Ditto. + * gfortran.dg/typebound_proc_1.f08: Ditto. + * gfortran.dg/typebound_proc_5.f03: Ditto. + * gfortran.dg/typebound_proc_6.f03: Ditto. + 2009-09-30 Jason Merrill <jason@redhat.com> * g++.dg/eh/init-temp1.C: Improve test. diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_3.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_3.f90 new file mode 100644 index 00000000000..c624de22d36 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_3.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! PR 40996: [F03] ALLOCATABLE scalars +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + +implicit none + +type :: t + integer, allocatable :: i +end type + +type(t)::x + +allocate(x%i) + +x%i = 13 +print *,x%i +if (.not. allocated(x%i)) call abort() + +deallocate(x%i) + +if (allocated(x%i)) call abort() + +end diff --git a/gcc/testsuite/gfortran.dg/allocate_derived_1.f90 b/gcc/testsuite/gfortran.dg/allocate_derived_1.f90 index d74851ef0b0..b9f6d5580a0 100644 --- a/gcc/testsuite/gfortran.dg/allocate_derived_1.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_derived_1.f90 @@ -1,8 +1,5 @@ ! { dg-do compile } ! -! FIXME: Remove -w after polymorphic entities are supported. -! { dg-options "-w" } -! ! ALLOCATE statements with derived type specification ! ! Contributed by Janus Weil <janus@gcc.gnu.org> diff --git a/gcc/testsuite/gfortran.dg/block_name_2.f90 b/gcc/testsuite/gfortran.dg/block_name_2.f90 index 590a015ffe9..d86e77e7a8c 100644 --- a/gcc/testsuite/gfortran.dg/block_name_2.f90 +++ b/gcc/testsuite/gfortran.dg/block_name_2.f90 @@ -43,8 +43,8 @@ program blocks end if select case (i) - case (1) s2 ! { dg-error "Expected the name of the SELECT CASE construct" } - case default s2 ! { dg-error "Expected the name of the SELECT CASE construct" } + case (1) s2 ! { dg-error "Syntax error in CASE specification" } + case default s2 ! { dg-error "Syntax error in CASE specification" } end select s2 ! { dg-error "Syntax error in END SELECT statement" } end select diff --git a/gcc/testsuite/gfortran.dg/class_1.f03 b/gcc/testsuite/gfortran.dg/class_1.f03 index bdd742b0105..f21133a05ad 100644 --- a/gcc/testsuite/gfortran.dg/class_1.f03 +++ b/gcc/testsuite/gfortran.dg/class_1.f03 @@ -1,8 +1,5 @@ ! { dg-do run } ! -! FIXME: Remove -w after polymorphic entities are supported. -! { dg-options "-w" } -! ! PR 40940: CLASS statement ! ! Contributed by Janus Weil <janus@gcc.gnu.org> diff --git a/gcc/testsuite/gfortran.dg/class_2.f03 b/gcc/testsuite/gfortran.dg/class_2.f03 index b4020450126..070d3f76fdd 100644 --- a/gcc/testsuite/gfortran.dg/class_2.f03 +++ b/gcc/testsuite/gfortran.dg/class_2.f03 @@ -1,8 +1,5 @@ ! { dg-do compile } ! -! FIXME: Remove -w after polymorphic entities are supported. -! { dg-options "-w" } -! ! PR 40940: CLASS statement ! ! Contributed by Janus Weil <janus@gcc.gnu.org> diff --git a/gcc/testsuite/gfortran.dg/class_allocate_1.f03 b/gcc/testsuite/gfortran.dg/class_allocate_1.f03 new file mode 100644 index 00000000000..844e1447fbf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_1.f03 @@ -0,0 +1,95 @@ +! { dg-do run } +! +! Allocating CLASS variables. +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + + implicit none + + type t1 + integer :: comp = 5 + class(t1),pointer :: cc + end type + + type, extends(t1) :: t2 + integer :: j + end type + + type, extends(t2) :: t3 + integer :: k + end type + + class(t1),pointer :: cp, cp2 + type(t3) :: x + integer :: i + + + ! (1) check that vindex is set correctly (for different cases) + + i = 0 + allocate(cp) + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 + type is (t3) + i = 3 + end select + deallocate(cp) + if (i /= 1) call abort() + + i = 0 + allocate(t2 :: cp) + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 + type is (t3) + i = 3 + end select + deallocate(cp) + if (i /= 2) call abort() + + i = 0 + allocate(cp, source = x) + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 + type is (t3) + i = 3 + end select + deallocate(cp) + if (i /= 3) call abort() + + i = 0 + allocate(t2 :: cp2) + allocate(cp, source = cp2) ! { dg-warning "not supported yet" } + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 + type is (t3) + i = 3 + end select + deallocate(cp) + deallocate(cp2) + if (i /= 2) call abort() + + + ! (2) check initialization (default initialization vs. SOURCE) + + allocate(cp) + if (cp%comp /= 5) call abort() + deallocate(cp) + + x%comp = 4 + allocate(cp, source=x) + if (cp%comp /= 4) call abort() + deallocate(cp) + +end diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90 index 2a73bdad35b..4513083ac5d 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90 @@ -1,8 +1,5 @@ ! { dg-do run } ! -! FIXME: Remove -w after polymorphic entities are supported. -! { dg-options "-w" } -! ! PR 39630: [F03] Procedure Pointer Components with PASS ! ! found at http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/4a827e8ced6efb0f/884b9eca6d7e6742 diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90 index 9e3cd5835e6..03770ce3ff8 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90 @@ -1,8 +1,5 @@ ! { dg-do run } ! -! FIXME: Remove -w after polymorphic entities are supported. -! { dg-options "-w" } -! ! PR 39630: [F03] Procedure Pointer Components with PASS ! ! taken from "The Fortran 2003 Handbook" (Adams et al., 2009) diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90 index 3c56794166a..add025cb050 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90 @@ -1,8 +1,5 @@ ! { dg-do run } ! -! FIXME: Remove -w after polymorphic entities are supported. -! { dg-options "-w" } -! ! PR 39630: [F03] Procedure Pointer Components with PASS ! ! taken from "Fortran 95/2003 explained" (Metcalf, Reid, Cohen, 2004) diff --git a/gcc/testsuite/gfortran.dg/same_type_as_1.f03 b/gcc/testsuite/gfortran.dg/same_type_as_1.f03 new file mode 100644 index 00000000000..ba13a0b731e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/same_type_as_1.f03 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! Error checking for the intrinsic function SAME_TYPE_AS. +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + + type :: t1 + integer :: i + end type + + type :: ts + sequence + integer :: j + end type + + TYPE(t1) :: x1 + TYPE(ts) :: x2 + + integer :: i + + print *, SAME_TYPE_AS (l,x1) ! { dg-error "must be of a derived type" } + print *, SAME_TYPE_AS (x1,x2) ! { dg-error "must be of an extensible type" } + +end diff --git a/gcc/testsuite/gfortran.dg/same_type_as_2.f03 b/gcc/testsuite/gfortran.dg/same_type_as_2.f03 new file mode 100644 index 00000000000..9a2110d47b6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/same_type_as_2.f03 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Verifying the runtime behavior of the intrinsic function SAME_TYPE_AS. +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + + type :: t1 + integer :: i + end type + + type :: t2 + integer :: j + end type + + CLASS(t1), pointer :: c1 + CLASS(t2), pointer :: c2 + TYPE(t1), target :: x1 + TYPE(t2) ,target :: x2 + + intrinsic :: SAME_TYPE_AS + logical :: l + + c1 => NULL() + + l = SAME_TYPE_AS (x1,x1) + print *,l + if (.not.l) call abort() + l = SAME_TYPE_AS (x1,x2) + print *,l + if (l) call abort() + + c1 => x1 + l = SAME_TYPE_AS (c1,x1) + print *,l + if (.not.l) call abort() + l = SAME_TYPE_AS (c1,x2) + print *,l + if (l) call abort() + + c1 => x2 + c2 => x2 + l = SAME_TYPE_AS (c1,c2) + print *,l + if (.not.l) call abort() + + c1 => x1 + c2 => x2 + l = SAME_TYPE_AS (c1,c2) + print *,l + if (l) call abort() + +end diff --git a/gcc/testsuite/gfortran.dg/select_6.f90 b/gcc/testsuite/gfortran.dg/select_6.f90 index 926659c28b4..0e0f0524423 100644 --- a/gcc/testsuite/gfortran.dg/select_6.f90 +++ b/gcc/testsuite/gfortran.dg/select_6.f90 @@ -5,6 +5,6 @@ integer(kind=1) :: i real :: r(3) select case (i) - case (129) r(4) = 0 { dg-error "Expected the name" } + case (129) r(4) = 0 ! { dg-error "Syntax error in CASE specification" } end select end diff --git a/gcc/testsuite/gfortran.dg/select_type_1.f03 b/gcc/testsuite/gfortran.dg/select_type_1.f03 new file mode 100644 index 00000000000..e764ec98f48 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_1.f03 @@ -0,0 +1,72 @@ +! { dg-do compile } +! +! Error checking for the SELECT TYPE statement +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + + type :: t1 + integer :: i = 42 + class(t1),pointer :: cp + end type + + type, extends(t1) :: t2 + integer :: j = 99 + end type + + type :: t3 + real :: r + end type + + type :: ts + sequence + integer :: k = 5 + end type + + class(t1), pointer :: a => NULL() + type(t1), target :: b + type(t2), target :: c + a => b + print *, a%i + + type is (t1) ! { dg-error "Unexpected TYPE IS statement" } + + select type (3.5) ! { dg-error "Selector must be a named variable" } + select type (a%cp) ! { dg-error "Selector must be a named variable" } + select type (b) ! { dg-error "Selector shall be polymorphic" } + + select type (a) + print *,"hello world!" ! { dg-error "Expected TYPE IS, CLASS IS or END SELECT" } + type is (t1) + 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)" + 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 (t2) label ! { dg-error "Syntax error" } + print *,"a is CLASS(t2)" + class default ! { dg-error "cannot be followed by a second DEFAULT CASE" } + print *,"default" + class default ! { dg-error "cannot be followed by a second DEFAULT CASE" } + print *,"default2" + end select + +label: select type (a) + type is (t1) label + print *,"a is TYPE(t1)" + type is (t2) ! { dg-error "overlaps with CASE label" } + print *,"a is TYPE(t2)" + type is (t2) ! { dg-error "overlaps with CASE label" } + print *,"a is still TYPE(t2)" + class is (t1) labe ! { dg-error "Expected block name" } + print *,"a is CLASS(t1)" + end select label + +end diff --git a/gcc/testsuite/gfortran.dg/select_type_2.f03 b/gcc/testsuite/gfortran.dg/select_type_2.f03 new file mode 100644 index 00000000000..08ac9fef6e8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_2.f03 @@ -0,0 +1,69 @@ +! { dg-do run } +! +! executing simple SELECT TYPE statements +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + + type :: t1 + integer :: i + end type t1 + + type, extends(t1) :: t2 + integer :: j + end type t2 + + type, extends(t1) :: t3 + real :: r + end type + + class(t1), pointer :: cp + type(t1), target :: a + type(t2), target :: b + type(t3), target :: c + integer :: i + + cp => a + i = 0 + + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 +! FIXME: CLASS IS is not yet supported +! class is (t1) +! i = 3 + end select + + if (i /= 1) call abort() + + cp => b + i = 0 + + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 +! FIXME: CLASS IS is not yet supported +! class is (t2) +! i = 3 + end select + + if (i /= 2) call abort() + + cp => c + i = 0 + + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 + class default + i = 3 + end select + + if (i /= 3) call abort() + +end diff --git a/gcc/testsuite/gfortran.dg/select_type_3.f03 b/gcc/testsuite/gfortran.dg/select_type_3.f03 new file mode 100644 index 00000000000..13cd3c11a82 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_3.f03 @@ -0,0 +1,42 @@ +! { dg-do run } +! +! SELECT TYPE with temporaries +! +! Contributed by Janus Weil <janus@gcc.gnu.org> + + type :: t1 + integer :: i = -1 + end type t1 + + type, extends(t1) :: t2 + integer :: j = -1 + end type t2 + + class(t1), pointer :: cp + type(t2), target :: b + + cp => b + + select type (cp) + type is (t1) + cp%i = 1 + type is (t2) + cp%j = 2 + end select + + print *,b%i,b%j + if (b%i /= -1) call abort() + if (b%j /= 2) call abort() + + select type (cp) + type is (t1) + cp%i = 4 + type is (t2) + cp%i = 3*cp%j + end select + + print *,b%i,b%j + if (b%i /= 6) call abort() + if (b%j /= 2) call abort() + +end diff --git a/gcc/testsuite/gfortran.dg/typebound_call_10.f03 b/gcc/testsuite/gfortran.dg/typebound_call_10.f03 index 77667fba733..ca6038e45ce 100644 --- a/gcc/testsuite/gfortran.dg/typebound_call_10.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_call_10.f03 @@ -1,8 +1,5 @@ ! { dg-do run } ! -! FIXME: Remove -w after polymorphic entities are supported. -! { dg-options "-w" } -! ! PR 39630: [F03] Procedure Pointer Components with PASS ! ! Contributed by Tobias Burnus <burnus@gcc.gnu.org> diff --git a/gcc/testsuite/gfortran.dg/typebound_call_2.f03 b/gcc/testsuite/gfortran.dg/typebound_call_2.f03 index f6e623c498a..5d70f7c17ef 100644 --- a/gcc/testsuite/gfortran.dg/typebound_call_2.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_call_2.f03 @@ -1,8 +1,5 @@ ! { dg-do run } -! FIXME: Remove -w after polymorphic entities are supported. -! { dg-options "-w" } - ! Type-bound procedures ! Check calls with passed-objects. diff --git a/gcc/testsuite/gfortran.dg/typebound_call_3.f03 b/gcc/testsuite/gfortran.dg/typebound_call_3.f03 index 028c5b124b0..eabb28ef18b 100644 --- a/gcc/testsuite/gfortran.dg/typebound_call_3.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_call_3.f03 @@ -1,8 +1,5 @@ ! { dg-do run } -! FIXME: Remove -w after polymorphic entities are supported. -! { dg-options "-w" } - ! Type-bound procedures ! Check that calls work across module-boundaries. diff --git a/gcc/testsuite/gfortran.dg/typebound_call_4.f03 b/gcc/testsuite/gfortran.dg/typebound_call_4.f03 index 25745fda488..cdbbea9ac01 100644 --- a/gcc/testsuite/gfortran.dg/typebound_call_4.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_call_4.f03 @@ -1,8 +1,5 @@ ! { dg-do compile } -! FIXME: Remove -w after polymorphic entities are supported. -! { dg-options "-w" } - ! Type-bound procedures ! Check for recognition/errors with more complicated references and some ! error-handling in general. diff --git a/gcc/testsuite/gfortran.dg/typebound_call_9.f03 b/gcc/testsuite/gfortran.dg/typebound_call_9.f03 index f2e128d3cb2..6bb2ca88303 100644 --- a/gcc/testsuite/gfortran.dg/typebound_call_9.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_call_9.f03 @@ -1,8 +1,5 @@ ! { dg-do compile } -! FIXME: Remove once polymorphic PASS is resolved -! { dg-options "-w" } - ! PR fortran/37638 ! If a PASS(arg) is invalid, a call to this routine later would ICE in ! resolving. Check that this also works for GENERIC, in addition to the diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_3.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_3.f03 index d70828265ca..d56f914897e 100644 --- a/gcc/testsuite/gfortran.dg/typebound_generic_3.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_generic_3.f03 @@ -1,8 +1,5 @@ ! { dg-do run } -! FIXME: Remove -w once switched to polymorphic passed-object dummy arguments. -! { dg-options "-w" } - ! Type-bound procedures ! Check calls with GENERIC bindings. diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_4.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_4.f03 index 28af021f85d..ff5cd0582cd 100644 --- a/gcc/testsuite/gfortran.dg/typebound_generic_4.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_generic_4.f03 @@ -1,8 +1,5 @@ ! { dg-do run } -! FIXME: Remove -w once the TYPE/CLASS issue is resolved -! { dg-options "-w" } - ! PR fortran/37588 ! This test used to not resolve the GENERIC binding. diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_1.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_1.f03 index 25565908fdb..f756a595b40 100644 --- a/gcc/testsuite/gfortran.dg/typebound_operator_1.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_operator_1.f03 @@ -1,6 +1,4 @@ ! { dg-do compile } -! { dg-options "-w" } -! FIXME: Remove -w once CLASS is fully supported. ! Type-bound procedures ! Check correct type-bound operator definitions. diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 index 71e8e4ffebf..57b34486313 100644 --- a/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 @@ -1,6 +1,4 @@ ! { dg-do compile } -! { dg-options "-w" } -! FIXME: Remove -w once CLASS is fully supported. ! Type-bound procedures ! Checks for correct errors with invalid OPERATOR/ASSIGNMENT usage. diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_3.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_3.f03 index 9f2369a1f07..51ad1d2f0f8 100644 --- a/gcc/testsuite/gfortran.dg/typebound_operator_3.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_operator_3.f03 @@ -1,6 +1,4 @@ ! { dg-do run } -! { dg-options "-w" } -! FIXME: Remove -w when CLASS is fully implemented. ! Type-bound procedures ! Check they can actually be called and run correctly. diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 index ee7c2989f6b..1ce2b97a0d7 100644 --- a/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 @@ -1,6 +1,4 @@ ! { dg-do compile } -! { dg-options "-w" } -! FIXME: Remove -w when CLASS is fully implemented. ! Type-bound procedures ! Check for errors with operator calls. diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_1.f08 b/gcc/testsuite/gfortran.dg/typebound_proc_1.f08 index 3437baaa63c..53868a4632c 100644 --- a/gcc/testsuite/gfortran.dg/typebound_proc_1.f08 +++ b/gcc/testsuite/gfortran.dg/typebound_proc_1.f08 @@ -1,8 +1,5 @@ ! { dg-do compile } -! FIXME: Remove -w after polymorphic entities are supported. -! { dg-options "-w" } - ! Type-bound procedures ! Test that the basic syntax for specific bindings is parsed and resolved. diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_5.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_5.f03 index 1251e3f97f9..fdd15b388d1 100644 --- a/gcc/testsuite/gfortran.dg/typebound_proc_5.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_proc_5.f03 @@ -1,8 +1,5 @@ ! { dg-do compile } -! FIXME: Remove -w after polymorphic entities are supported. -! { dg-options "-w" } - ! Type-bound procedures ! Test for errors in specific bindings, during resolution. @@ -58,8 +55,8 @@ MODULE testmod PROCEDURE, PASS :: e1 => proc_noarg ! { dg-error "at least one argument" } PROCEDURE :: e2 => proc_noarg ! { dg-error "at least one argument" } PROCEDURE, PASS(me) :: e3 => proc_nome ! { dg-error "no argument 'me'" } - PROCEDURE, PASS(me) :: e4 => proc_mewrong ! { dg-error "of the derived" } - PROCEDURE, PASS :: e5 => proc_mewrong ! { dg-error "of the derived" } + PROCEDURE, PASS(me) :: e4 => proc_mewrong ! { dg-error "Non-polymorphic passed-object dummy argument" } + PROCEDURE, PASS :: e5 => proc_mewrong ! { dg-error "Non-polymorphic passed-object dummy argument" } PROCEDURE :: e6 => noproc ! { dg-error "module procedure" } PROCEDURE :: e7 => proc_nointf ! { dg-error "explicit interface" } PROCEDURE, NOPASS :: e8 => proc_abstract_intf ! { dg-error "explicit interface" } diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 index eba48366098..83765bf3009 100644 --- a/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 @@ -1,8 +1,5 @@ ! { dg-do compile } -! FIXME: Remove -w after polymorphic entities are supported. -! { dg-options "-w" } - ! Type-bound procedures ! Test for the check if overriding methods "match" the overridden ones by their ! characteristics. |