From: Fritz Reese Date: Sat, 7 May 2016 23:16:23 +0000 (+0000) Subject: re PR fortran/56226 (Add support for DEC UNION and MAP extensions) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=f6288c243153b97fb009a53a927c60dc30d4dd84;p=gcc.git re PR fortran/56226 (Add support for DEC UNION and MAP extensions) 2016-05-07 Fritz Reese PR fortran/56226 * module.c (dt_upper_string): Rename to gfc_dt_upper_string (dt_lower_string): Likewise. * gfortran.h: Make new gfc_dt_upper/lower_string global. * class.c: Use gfc_dt_upper_string. * decl.c: Likewise. * symbol.c: Likewise. * resolve.c (resolve_component): New function. (resolve_fl_derived0): Move component loop code to resolve_component. * parse.c (check_component): New function. (parse_derived): Move loop code to check_component. * lang.opt, invoke.texi, options.c : New option -fdec-structure. * libgfortran.h (bt): New basic type BT_UNION. * gfortran.h (gfc_option): New option -fdec-structure. (gfc_get_union_type, gfc_compare_union_types): New prototypes. (gfc_bt_struct, gfc_fl_struct, case_bt_struct, case_fl_struct): New macros. (gfc_find_component): Change prototype. * match.h (gfc_match_member_sep, gfc_match_map, gfc_match_union, gfc_match_structure_decl): New prototypes. * parse.h (gfc_comp_struct): New macro. * symbol.c (gfc_find_component): Search for components in nested unions * class.c (insert_component_ref, gfc_add_component_ref, add_proc_comp, copy_vtab_proc_comps): Update calls to gfc_find_component. * primary.c (gfc_convert_to_structure_constructor): Likewise. * symbol.c (gfc_add_component): Likewise. * resolve.c (resolve_typebound_function, resolve_typebound_subroutine, resolve_typebound_procedure, resolve_component, resolve_fl_derived): Likewise. * expr.c (get_union_init, component_init): New functions. * decl.c (match_clist_expr, match_record_decl, get_struct_decl, gfc_match_map, gfc_match_union, gfc_match_structure_decl): Likewise. * interface.c (compare_components, gfc_compare_union_types): Likewise. * match.c (gfc_match_member_sep): Likewise. * parse.c (check_component, parse_union, parse_struct_map): Likewise. * resolve.c (resolve_fl_struct): Likewise. * symbol.c (find_union_component): Likewise. * trans-types.c (gfc_get_union_type): Likewise. * parse.c (parse_derived): Use new functions. * interface.c (gfc_compare_derived_types, gfc_compare_types): Likewise. * expr.c (gfc_default_initializer): Likewise. * gfortran.texi: Support for DEC structures, unions, and maps. * gfortran.h (gfc_statement, sym_flavor): Likewise. * check.c (gfc_check_kill_sub): Likewise. * expr.c (gfc_copy_expr, simplify_const_ref, gfc_has_default_initializer): Likewise. * decl.c (build_sym, match_data_constant, add_init_expr_to_sym, match_pointer_init, build_struct, variable_decl, gfc_match_decl_type_spec, gfc_mach_data-decl, gfc_match_entry, gfc_match_end, gfc_match_derived_decl): Likewise. * interface.c (check_interface0, check_interface1, gfc_search_interface): Likewise. * misc.c (gfc_basic_typename, gfc_typename): Likewise. * module.c (add_true_name, build_tnt, bt_types, mio_typespec, fix_mio_expr, load_needed, mio_symbol, read_module, write_symbol, gfc_get_module_backend_decl): Likewise. * parse.h (gfc_compile_state): Likewise. * parse.c (decode_specification_statement, decode_statement, gfc_ascii_statement, verify_st_order, parse_spec): Likewise. * primary.c (gfc_match_varspec, gfc_match_structure_constructor, gfc_match_rvalue, match_variable): Likewise. * resolve.c (find_arglists, resolve_structure_cons, is_illegal_recursion, resolve_generic_f, get_declared_from_expr, resolve_typebound_subroutine, resolve_allocate_expr, nonscalar_typebound_assign, generate_component_assignments, resolve_fl_variable_derived, check_defined_assignments, resolve_component, resolve_symbol, resolve_equivalence_derived): Likewise. * symbol.c (flavors, check_conflict, gfc_add_flavor, gfc_use_derived, gfc_restore_last_undo_checkpoint, gfc_type_compatible, gfc_find_dt_in_generic): Likewise. * trans-decl.c (gfc_get_module_backend_decl, create_function_arglist, gfc_create_module_variable, check_constant_initializer): Likewise. * trans-expr.c (gfc_conv_component_ref, gfc_conv_initializer, gfc_trans_alloc_subarray_assign, gfc_trans_subcomponent_assign, gfc_conv_structure, gfc_trans_scalar_assign, copyable_array_p): Likewise. * trans-io.c (transfer_namelist_element, transfer_expr, gfc_trans_transfer): Likewise. * trans-stmt.c (gfc_trans_deallocate): Likewise. * trans-types.c (gfc_typenode_for_spec, gfc_copy_dt_decls_ifequal, gfc_get_derived_type): Likewise. 2016-05-07 Fritz Reese PR fortran/56226 * gfortran.dg/dec_structure_1.f90: New testcase. * gfortran.dg/dec_structure_2.f90: Ditto. * gfortran.dg/dec_structure_3.f90: Ditto. * gfortran.dg/dec_structure_4.f90: Ditto. * gfortran.dg/dec_structure_5.f90: Ditto. * gfortran.dg/dec_structure_6.f90: Ditto. * gfortran.dg/dec_structure_7.f90: Ditto. * gfortran.dg/dec_structure_8.f90: Ditto. * gfortran.dg/dec_structure_9.f90: Ditto. * gfortran.dg/dec_structure_10.f90: Ditto. * gfortran.dg/dec_structure_11.f90: Ditto. * gfortran.dg/dec_union_1.f90: Ditto. * gfortran.dg/dec_union_2.f90: Ditto. * gfortran.dg/dec_union_3.f90: Ditto. * gfortran.dg/dec_union_4.f90: Ditto. * gfortran.dg/dec_union_5.f90: Ditto. * gfortran.dg/dec_union_6.f90: Ditto. * gfortran.dg/dec_union_7.f90: Ditto. From-SVN: r235999 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 950e1c331ce..bad524c82ea 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,88 @@ +2016-05-07 Fritz Reese + + PR fortran/56226 + * module.c (dt_upper_string): Rename to gfc_dt_upper_string + (dt_lower_string): Likewise. + * gfortran.h: Make new gfc_dt_upper/lower_string global. + * class.c: Use gfc_dt_upper_string. + * decl.c: Likewise. + * symbol.c: Likewise. + * resolve.c (resolve_component): New function. + (resolve_fl_derived0): Move component loop code to resolve_component. + * parse.c (check_component): New function. + (parse_derived): Move loop code to check_component. + * lang.opt, invoke.texi, options.c : New option -fdec-structure. + * libgfortran.h (bt): New basic type BT_UNION. + * gfortran.h (gfc_option): New option -fdec-structure. + (gfc_get_union_type, gfc_compare_union_types): New prototypes. + (gfc_bt_struct, gfc_fl_struct, case_bt_struct, case_fl_struct): New + macros. + (gfc_find_component): Change prototype. + * match.h (gfc_match_member_sep, gfc_match_map, gfc_match_union, + gfc_match_structure_decl): New prototypes. + * parse.h (gfc_comp_struct): New macro. + * symbol.c (gfc_find_component): Search for components in nested unions + * class.c (insert_component_ref, gfc_add_component_ref, add_proc_comp, + copy_vtab_proc_comps): Update calls to gfc_find_component. + * primary.c (gfc_convert_to_structure_constructor): Likewise. + * symbol.c (gfc_add_component): Likewise. + * resolve.c (resolve_typebound_function, resolve_typebound_subroutine, + resolve_typebound_procedure, resolve_component, resolve_fl_derived): + Likewise. + * expr.c (get_union_init, component_init): New functions. + * decl.c (match_clist_expr, match_record_decl, get_struct_decl, + gfc_match_map, gfc_match_union, gfc_match_structure_decl): Likewise. + * interface.c (compare_components, gfc_compare_union_types): Likewise. + * match.c (gfc_match_member_sep): Likewise. + * parse.c (check_component, parse_union, parse_struct_map): Likewise. + * resolve.c (resolve_fl_struct): Likewise. + * symbol.c (find_union_component): Likewise. + * trans-types.c (gfc_get_union_type): Likewise. + * parse.c (parse_derived): Use new functions. + * interface.c (gfc_compare_derived_types, gfc_compare_types): Likewise. + * expr.c (gfc_default_initializer): Likewise. + * gfortran.texi: Support for DEC structures, unions, and maps. + * gfortran.h (gfc_statement, sym_flavor): Likewise. + * check.c (gfc_check_kill_sub): Likewise. + * expr.c (gfc_copy_expr, simplify_const_ref, + gfc_has_default_initializer): Likewise. + * decl.c (build_sym, match_data_constant, add_init_expr_to_sym, + match_pointer_init, build_struct, variable_decl, + gfc_match_decl_type_spec, gfc_mach_data-decl, gfc_match_entry, + gfc_match_end, gfc_match_derived_decl): Likewise. + * interface.c (check_interface0, check_interface1, + gfc_search_interface): Likewise. + * misc.c (gfc_basic_typename, gfc_typename): Likewise. + * module.c (add_true_name, build_tnt, bt_types, mio_typespec, + fix_mio_expr, load_needed, mio_symbol, read_module, write_symbol, + gfc_get_module_backend_decl): Likewise. + * parse.h (gfc_compile_state): Likewise. + * parse.c (decode_specification_statement, decode_statement, + gfc_ascii_statement, verify_st_order, parse_spec): Likewise. + * primary.c (gfc_match_varspec, gfc_match_structure_constructor, + gfc_match_rvalue, match_variable): Likewise. + * resolve.c (find_arglists, resolve_structure_cons, + is_illegal_recursion, resolve_generic_f, get_declared_from_expr, + resolve_typebound_subroutine, resolve_allocate_expr, + nonscalar_typebound_assign, generate_component_assignments, + resolve_fl_variable_derived, check_defined_assignments, + resolve_component, resolve_symbol, resolve_equivalence_derived): + Likewise. + * symbol.c (flavors, check_conflict, gfc_add_flavor, gfc_use_derived, + gfc_restore_last_undo_checkpoint, gfc_type_compatible, + gfc_find_dt_in_generic): Likewise. + * trans-decl.c (gfc_get_module_backend_decl, create_function_arglist, + gfc_create_module_variable, check_constant_initializer): Likewise. + * trans-expr.c (gfc_conv_component_ref, gfc_conv_initializer, + gfc_trans_alloc_subarray_assign, gfc_trans_subcomponent_assign, + gfc_conv_structure, gfc_trans_scalar_assign, copyable_array_p): + Likewise. + * trans-io.c (transfer_namelist_element, transfer_expr, + gfc_trans_transfer): Likewise. + * trans-stmt.c (gfc_trans_deallocate): Likewise. + * trans-types.c (gfc_typenode_for_spec, gfc_copy_dt_decls_ifequal, + gfc_get_derived_type): Likewise. + 2016-05-05 Jakub Jelinek * openmp.c (gfc_match_omp_clauses): Restructuralize, so that clause diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 05133c32043..d26e45ec406 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2592,7 +2592,7 @@ gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status) bool gfc_check_kind (gfc_expr *x) { - if (x->ts.type == BT_DERIVED || x->ts.type == BT_CLASS) + if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS) { gfc_error ("%qs argument of %qs intrinsic at %L must be of " "intrinsic type", gfc_current_intrinsic_arg[0]->name, diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 6a7339f1bc1..3627828d21f 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -78,12 +78,11 @@ insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name) gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS); type_sym = ts->u.derived; - new_ref = gfc_get_ref (); - new_ref->type = REF_COMPONENT; - new_ref->next = *ref; - new_ref->u.c.sym = type_sym; - new_ref->u.c.component = gfc_find_component (type_sym, name, true, true); + gfc_find_component (type_sym, name, true, true, &new_ref); gcc_assert (new_ref->u.c.component); + while (new_ref->next) + new_ref = new_ref->next; + new_ref->next = *ref; if (new_ref->next) { @@ -206,8 +205,9 @@ gfc_fix_class_refs (gfc_expr *e) void gfc_add_component_ref (gfc_expr *e, const char *name) { + gfc_component *c; gfc_ref **tail = &(e->ref); - gfc_ref *next = NULL; + gfc_ref *ref, *next = NULL; gfc_symbol *derived = e->symtree->n.sym->ts.u.derived; while (*tail != NULL) { @@ -237,14 +237,13 @@ gfc_add_component_ref (gfc_expr *e, const char *name) else /* Avoid losing memory. */ gfc_free_ref_list (*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); + c = gfc_find_component (derived, name, true, true, tail); + gcc_assert (c); + for (ref = *tail; ref->next; ref = ref->next) + ; + ref->next = next; if (!next) - e->ts = (*tail)->u.c.component->ts; + e->ts = c->ts; } @@ -477,8 +476,7 @@ get_unique_type_string (char *string, gfc_symbol *derived) if (derived->attr.unlimited_polymorphic) strcpy (dt_name, "STAR"); else - strcpy (dt_name, derived->name); - dt_name[0] = TOUPPER (dt_name[0]); + strcpy (dt_name, gfc_dt_upper_string (derived->name)); if (derived->attr.unlimited_polymorphic) sprintf (string, "_%s", dt_name); else if (derived->module) @@ -751,7 +749,7 @@ add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb) if (tb->non_overridable) return; - c = gfc_find_component (vtype, name, true, true); + c = gfc_find_component (vtype, name, true, true, NULL); if (c == NULL) { @@ -820,7 +818,7 @@ copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype) for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next) { - if (gfc_find_component (vtype, cmp->name, true, true)) + if (gfc_find_component (vtype, cmp->name, true, true, NULL)) continue; add_proc_comp (vtype, cmp->name, cmp->tb); diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 80ec39cb86b..0b8787ac2b2 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -391,13 +391,13 @@ match_data_constant (gfc_expr **result) if (sym == NULL || (sym->attr.flavor != FL_PARAMETER - && (!dt_sym || dt_sym->attr.flavor != FL_DERIVED))) + && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor)))) { gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C", name); return MATCH_ERROR; } - else if (dt_sym && dt_sym->attr.flavor == FL_DERIVED) + else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor)) return gfc_match_structure_constructor (dt_sym, result); /* Check to see if the value is an initialization array expression. */ @@ -606,6 +606,161 @@ cleanup: /************************ Declaration statements *********************/ +/* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization + list). The difference here is the expression is a list of constants + and is surrounded by '/'. + The typespec ts must match the typespec of the variable which the + clist is initializing. + The arrayspec tells whether this should match a list of constants + corresponding to array elements or a scalar (as == NULL). */ + +static match +match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as) +{ + gfc_constructor_base array_head = NULL; + gfc_expr *expr = NULL; + match m; + locus where; + mpz_t repeat, size; + bool scalar; + int cmp; + + gcc_assert (ts); + + mpz_init_set_ui (repeat, 0); + mpz_init (size); + scalar = !as || !as->rank; + + /* We have already matched '/' - now look for a constant list, as with + top_val_list from decl.c, but append the result to an array. */ + if (gfc_match ("/") == MATCH_YES) + { + gfc_error ("Empty old style initializer list at %C"); + goto cleanup; + } + + where = gfc_current_locus; + for (;;) + { + m = match_data_constant (&expr); + if (m != MATCH_YES) + expr = NULL; /* match_data_constant may set expr to garbage */ + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + /* Found r in repeat spec r*c; look for the constant to repeat. */ + if ( gfc_match_char ('*') == MATCH_YES) + { + if (scalar) + { + gfc_error ("Repeat spec invalid in scalar initializer at %C"); + goto cleanup; + } + if (expr->ts.type != BT_INTEGER) + { + gfc_error ("Repeat spec must be an integer at %C"); + goto cleanup; + } + mpz_set (repeat, expr->value.integer); + gfc_free_expr (expr); + expr = NULL; + + m = match_data_constant (&expr); + if (m == MATCH_NO) + gfc_error ("Expected data constant after repeat spec at %C"); + if (m != MATCH_YES) + goto cleanup; + } + /* No repeat spec, we matched the data constant itself. */ + else + mpz_set_ui (repeat, 1); + + if (!scalar) + { + /* Add the constant initializer as many times as repeated. */ + for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1)) + { + /* Make sure types of elements match */ + if(ts && !gfc_compare_types (&expr->ts, ts) + && !gfc_convert_type (expr, ts, 1)) + goto cleanup; + + gfc_constructor_append_expr (&array_head, + gfc_copy_expr (expr), &gfc_current_locus); + } + + gfc_free_expr (expr); + expr = NULL; + } + + /* For scalar initializers quit after one element. */ + else + { + if(gfc_match_char ('/') != MATCH_YES) + { + gfc_error ("End of scalar initializer expected at %C"); + goto cleanup; + } + break; + } + + if (gfc_match_char ('/') == MATCH_YES) + break; + if (gfc_match_char (',') == MATCH_NO) + goto syntax; + } + + /* Set up expr as an array constructor. */ + if (!scalar) + { + expr = gfc_get_array_expr (ts->type, ts->kind, &where); + expr->ts = *ts; + expr->value.constructor = array_head; + + expr->rank = as->rank; + expr->shape = gfc_get_shape (expr->rank); + + /* Validate sizes. */ + gcc_assert (gfc_array_size (expr, &size)); + gcc_assert (spec_size (as, &repeat)); + cmp = mpz_cmp (size, repeat); + if (cmp < 0) + gfc_error ("Not enough elements in array initializer at %C"); + else if (cmp > 0) + gfc_error ("Too many elements in array initializer at %C"); + if (cmp) + goto cleanup; + } + + /* Make sure scalar types match. */ + else if (!gfc_compare_types (&expr->ts, ts) + && !gfc_convert_type (expr, ts, 1)) + goto cleanup; + + if (expr->ts.u.cl) + expr->ts.u.cl->length_from_typespec = 1; + + *result = expr; + mpz_clear (size); + mpz_clear (repeat); + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in old style initializer list at %C"); + +cleanup: + if (expr) + expr->value.constructor = NULL; + gfc_free_expr (expr); + gfc_constructor_free (array_head); + mpz_clear (size); + mpz_clear (repeat); + return MATCH_ERROR; +} + + /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */ static bool @@ -1239,7 +1394,8 @@ build_sym (const char *name, gfc_charlen *cl, bool cl_deferred, st = gfc_find_symtree (gfc_current_ns->sym_root, u_name); - if (st != 0) + /* STRUCTURE types can alias symbol names */ + if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT) { gfc_error ("Symbol %qs at %C also declared as a type at %L", name, &st->n.sym->declared_at); @@ -1469,7 +1625,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 derived type variables and procedure pointers. */ - if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED + if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type) && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS && !sym->attr.proc_pointer && !gfc_check_assign_symbol (sym, NULL, init)) @@ -1608,7 +1764,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) If we mark my_int as iso_c (since we can see it's value is equal to one of the named constants), then my_int_2 will be considered C interoperable. */ - if (sym->ts.type != BT_CHARACTER && sym->ts.type != BT_DERIVED) + if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type)) { sym->ts.is_iso_c |= init->ts.is_iso_c; sym->ts.is_c_interop |= init->ts.is_c_interop; @@ -1666,6 +1822,7 @@ static bool build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, gfc_array_spec **as) { + gfc_state_data *s; gfc_component *c; bool t = true; @@ -1689,6 +1846,35 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, } } + /* If we are in a nested union/map definition, gfc_add_component will not + properly find repeated components because: + (i) gfc_add_component does a flat search, where components of unions + and maps are implicity chained so nested components may conflict. + (ii) Unions and maps are not linked as components of their parent + structures until after they are parsed. + For (i) we use gfc_find_component which searches recursively, and for (ii) + we search each block directly from the parse stack until we find the top + level structure. */ + + s = gfc_state_stack; + if (s->state == COMP_UNION || s->state == COMP_MAP) + { + while (s->state == COMP_UNION || gfc_comp_struct (s->state)) + { + c = gfc_find_component (s->sym, name, true, true, NULL); + if (c != NULL) + { + gfc_error_now ("Component '%s' at %C already declared at %L", + name, &c->loc); + return false; + } + /* Break after we've searched the entire chain. */ + if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE) + break; + s = s->previous; + } + } + if (!gfc_add_component (gfc_current_block(), name, &c)) return false; @@ -1868,7 +2054,7 @@ match_pointer_init (gfc_expr **init, int procptr) { match m; - if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED) + if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state)) { gfc_error ("Initialization of pointer at %C is not allowed in " "a PURE procedure"); @@ -2062,7 +2248,7 @@ variable_decl (int elem) /* If this symbol has already shown up in a Cray Pointer declaration, and this is not a component declaration, then we want to set the type & bail out. */ - if (flag_cray_pointer && gfc_current_state () != COMP_DERIVED) + if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ())) { gfc_find_symbol (name, gfc_current_ns, 1, &sym); if (sym != NULL && sym->attr.cray_pointee) @@ -2127,7 +2313,7 @@ variable_decl (int elem) For components of derived types, it is not true, so we don't create a symbol for those yet. If we fail to create the symbol, bail out. */ - if (gfc_current_state () != COMP_DERIVED + if (!gfc_comp_struct (gfc_current_state ()) && !build_sym (name, cl, cl_deferred, &as, &var_locus)) { m = MATCH_ERROR; @@ -2154,6 +2340,9 @@ variable_decl (int elem) if (!gfc_notify_std (GFC_STD_GNU, "Old-style " "initialization at %C")) return MATCH_ERROR; + + /* Allow old style initializations for components of STRUCTUREs and MAPs + but not components of derived types. */ else if (gfc_current_state () == COMP_DERIVED) { gfc_error ("Invalid old style initialization for derived type " @@ -2162,7 +2351,23 @@ variable_decl (int elem) goto cleanup; } - return match_old_style_init (name); + /* For structure components, read the initializer as a special + expression and let the rest of this function apply the initializer + as usual. */ + else if (gfc_comp_struct (gfc_current_state ())) + { + m = match_clist_expr (&initializer, ¤t_ts, as); + if (m == MATCH_NO) + gfc_error ("Syntax error in old style initialization of %s at %C", + name); + if (m != MATCH_YES) + goto cleanup; + } + + /* Otherwise we treat the old style initialization just like a + DATA declaration for the current variable. */ + else + return match_old_style_init (name); } /* The double colon must be present in order to have initializers. @@ -2200,7 +2405,7 @@ variable_decl (int elem) } if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL) - && gfc_state_stack->state != COMP_DERIVED) + && !gfc_comp_struct (gfc_state_stack->state)) { gfc_error ("Initialization of variable at %C is not allowed in " "a PURE procedure"); @@ -2208,7 +2413,7 @@ variable_decl (int elem) } if (current_attr.flavor != FL_PARAMETER - && gfc_state_stack->state != COMP_DERIVED) + && !gfc_comp_struct (gfc_state_stack->state)) gfc_unset_implicit_pure (gfc_current_ns->proc_name); if (m != MATCH_YES) @@ -2217,7 +2422,7 @@ variable_decl (int elem) } if (initializer != NULL && current_attr.allocatable - && gfc_current_state () == COMP_DERIVED) + && gfc_comp_struct (gfc_current_state ())) { gfc_error ("Initialization of allocatable component at %C is not " "allowed"); @@ -2228,7 +2433,7 @@ variable_decl (int elem) /* Add the initializer. Note that it is fine if initializer is NULL here, because we sometimes also need to check if a declaration *must* have an initialization expression. */ - if (gfc_current_state () != COMP_DERIVED) + if (!gfc_comp_struct (gfc_current_state ())) t = add_init_expr_to_sym (name, &initializer, &var_locus); else { @@ -2236,6 +2441,12 @@ variable_decl (int elem) && !current_attr.pointer && !initializer) initializer = gfc_default_initializer (¤t_ts); t = build_struct (name, cl, &initializer, &as); + + /* If we match a nested structure definition we expect to see the + * body even if the variable declarations blow up, so we need to keep + * the structure declaration around. */ + if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT) + gfc_commit_symbol (gfc_new_block); } m = (t) ? MATCH_YES : MATCH_ERROR; @@ -2724,6 +2935,36 @@ done: } +/* Matches a RECORD declaration. */ + +static match +match_record_decl (const char *name) +{ + locus old_loc; + old_loc = gfc_current_locus; + + if (gfc_match (" record") == MATCH_YES) + { + if (!gfc_option.flag_dec_structure) + { + gfc_current_locus = old_loc; + gfc_error ("RECORD at %C is an extension, enable it with " + "-fdec-structure"); + return MATCH_ERROR; + } + if (gfc_match (" /%n/", name) != MATCH_YES) + { + gfc_error ("Structure name expected after RECORD at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + return MATCH_YES; + } + + gfc_current_locus = old_loc; + return MATCH_NO; +} + /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts structure to the matched specification. This is necessary for FUNCTION and IMPLICIT statements. @@ -2781,7 +3022,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) { if ((m = gfc_match ("*)")) != MATCH_YES) return m; - if (gfc_current_state () == COMP_DERIVED) + if (gfc_comp_struct (gfc_current_state ())) { gfc_error ("Assumed type at %C is not allowed for components"); return MATCH_ERROR; @@ -2892,10 +3133,51 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) if (matched_type) m = gfc_match_char (')'); - if (m == MATCH_YES) - ts->type = BT_DERIVED; + if (m != MATCH_YES) + m = match_record_decl (name); + + if (matched_type || m == MATCH_YES) + { + ts->type = BT_DERIVED; + /* We accept record/s/ or type(s) where s is a structure, but we + * don't need all the extra derived-type stuff for structures. */ + if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym)) + { + gfc_error ("Type name '%s' at %C is ambiguous", name); + return MATCH_ERROR; + } + if (sym && sym->attr.flavor == FL_STRUCT) + { + ts->u.derived = sym; + return MATCH_YES; + } + /* Actually a derived type. */ + } + else { + /* Match nested STRUCTURE declarations; only valid within another + structure declaration. */ + m = gfc_match (" structure"); + if (m == MATCH_ERROR) + return MATCH_ERROR; + else if (m == MATCH_YES) + { + if ( gfc_current_state () != COMP_STRUCTURE + && gfc_current_state () != COMP_MAP) + return MATCH_ERROR; + + m = gfc_match_structure_decl (); + if (m == MATCH_YES) + { + /* gfc_new_block is updated by match_structure_decl. */ + ts->type = BT_DERIVED; + ts->u.derived = gfc_new_block; + return MATCH_YES; + } + return MATCH_ERROR; + } + /* Match CLASS declarations. */ m = gfc_match (" class ( * )"); if (m == MATCH_ERROR) @@ -2964,9 +3246,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) stored in a symtree with the first letter of the name capitalized; the symtree with the all lower-case name contains the associated generic function. */ - dt_name = gfc_get_string ("%c%s", - (char) TOUPPER ((unsigned char) name[0]), - (const char*)&name[1]); + dt_name = gfc_dt_upper_string (name); sym = NULL; dt_sym = NULL; if (ts->kind != -1) @@ -2998,7 +3278,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return MATCH_NO; } - if ((sym->attr.flavor != FL_UNKNOWN + if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic)) || sym->attr.subroutine) { @@ -3038,7 +3318,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) gfc_set_sym_referenced (dt_sym); - if (dt_sym->attr.flavor != FL_DERIVED + if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL)) return MATCH_ERROR; @@ -3480,9 +3760,7 @@ gfc_match_import (void) letter of the name capitalized; the symtree with the all lower-case name contains the associated generic function. */ st = gfc_new_symtree (&gfc_current_ns->sym_root, - gfc_get_string ("%c%s", - (char) TOUPPER ((unsigned char) name[0]), - &name[1])); + gfc_dt_upper_string (name)); st->n.sym = sym; sym->refs++; sym->attr.imported = 1; @@ -4497,7 +4775,7 @@ gfc_match_data_decl (void) return m; if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) - && gfc_current_state () != COMP_DERIVED) + && !gfc_comp_struct (gfc_current_state ())) { sym = gfc_use_derived (current_ts.u.derived); @@ -4526,17 +4804,19 @@ gfc_match_data_decl (void) && !current_ts.u.derived->attr.zero_comp) { - if (current_attr.pointer && gfc_current_state () == COMP_DERIVED) + if (current_attr.pointer && gfc_comp_struct (gfc_current_state ())) goto ok; gfc_find_symbol (current_ts.u.derived->name, current_ts.u.derived->ns, 1, &sym); /* Any symbol that we find had better be a type definition - which has its components defined. */ - if (sym != NULL && sym->attr.flavor == FL_DERIVED + which has its components defined, or be a structure definition + actively being parsed. */ + if (sym != NULL && gfc_fl_struct (sym->attr.flavor) && (current_ts.u.derived->components != NULL - || current_ts.u.derived->attr.zero_comp)) + || current_ts.u.derived->attr.zero_comp + || current_ts.u.derived == gfc_new_block)) goto ok; gfc_error ("Derived type at %C has not been previously defined " @@ -5791,6 +6071,10 @@ gfc_match_entry (void) gfc_error ("ENTRY statement at %C cannot appear within " "an INTERFACE"); break; + case COMP_STRUCTURE: + gfc_error ("ENTRY statement at %C cannot appear within " + "a STRUCTURE block"); + break; case COMP_DERIVED: gfc_error ("ENTRY statement at %C cannot appear within " "a DERIVED TYPE block"); @@ -6450,6 +6734,24 @@ gfc_match_end (gfc_statement *st) eos_ok = 0; break; + case COMP_MAP: + *st = ST_END_MAP; + target = " map"; + eos_ok = 0; + break; + + case COMP_UNION: + *st = ST_END_UNION; + target = " union"; + eos_ok = 0; + break; + + case COMP_STRUCTURE: + *st = ST_END_STRUCTURE; + target = " structure"; + eos_ok = 0; + break; + case COMP_DERIVED: case COMP_DERIVED_CONTAINS: *st = ST_END_TYPE; @@ -8020,6 +8322,208 @@ gfc_get_type_attr_spec (symbol_attribute *attr, char *name) } +/* Common function for type declaration blocks similar to derived types, such + as STRUCTURES and MAPs. Unlike derived types, a structure type + does NOT have a generic symbol matching the name given by the user. + STRUCTUREs can share names with variables and PARAMETERs so we must allow + for the creation of an independent symbol. + Other parameters are a message to prefix errors with, the name of the new + type to be created, and the flavor to add to the resulting symbol. */ + +static bool +get_struct_decl (const char *name, sym_flavor fl, locus *decl, + gfc_symbol **result) +{ + gfc_symbol *sym; + locus where; + + gcc_assert (name[0] == (char) TOUPPER (name[0])); + + if (decl) + where = *decl; + else + where = gfc_current_locus; + + if (gfc_get_symbol (name, NULL, &sym)) + return false; + + if (!sym) + { + gfc_internal_error ("Failed to create structure type '%s' at %C", name); + return false; + } + + if (sym->components != NULL || sym->attr.zero_comp) + { + gfc_error ("Type definition of '%s' at %C was already defined at %L", + sym->name, &sym->declared_at); + return false; + } + + sym->declared_at = where; + + if (sym->attr.flavor != fl + && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL)) + return false; + + if (!sym->hash_value) + /* Set the hash for the compound name for this type. */ + sym->hash_value = gfc_hash_value (sym); + + /* Normally the type is expected to have been completely parsed by the time + a field declaration with this type is seen. For unions, maps, and nested + structure declarations, we need to indicate that it is okay that we + haven't seen any components yet. This will be updated after the structure + is fully parsed. */ + sym->attr.zero_comp = 0; + + /* Structures always act like derived-types with the SEQUENCE attribute */ + gfc_add_sequence (&sym->attr, sym->name, NULL); + + if (result) *result = sym; + + return true; +} + + +/* Match the opening of a MAP block. Like a struct within a union in C; + behaves identical to STRUCTURE blocks. */ + +match +gfc_match_map (void) +{ + /* Counter used to give unique internal names to map structures. */ + static unsigned int gfc_map_id = 0; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + locus old_loc; + + old_loc = gfc_current_locus; + + if (gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after MAP statement at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + /* Map blocks are anonymous so we make up unique names for the symbol table + which are invalid Fortran identifiers. */ + snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++); + + if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym)) + return MATCH_ERROR; + + gfc_new_block = sym; + + return MATCH_YES; +} + + +/* Match the opening of a UNION block. */ + +match +gfc_match_union (void) +{ + /* Counter used to give unique internal names to union types. */ + static unsigned int gfc_union_id = 0; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + locus old_loc; + + old_loc = gfc_current_locus; + + if (gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after UNION statement at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + /* Unions are anonymous so we make up unique names for the symbol table + which are invalid Fortran identifiers. */ + snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++); + + if (!get_struct_decl (name, FL_UNION, &old_loc, &sym)) + return MATCH_ERROR; + + gfc_new_block = sym; + + return MATCH_YES; +} + + +/* Match the beginning of a STRUCTURE declaration. This is similar to + matching the beginning of a derived type declaration with a few + twists. The resulting type symbol has no access control or other + interesting attributes. */ + +match +gfc_match_structure_decl (void) +{ + /* Counter used to give unique internal names to anonymous structures. */ + int gfc_structure_id = 0; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + match m; + locus where; + + if(!gfc_option.flag_dec_structure) + { + gfc_error ("STRUCTURE at %C is a DEC extension, enable with " + "-fdec-structure"); + return MATCH_ERROR; + } + + name[0] = '\0'; + + m = gfc_match (" /%n/", name); + if (m != MATCH_YES) + { + /* Non-nested structure declarations require a structure name. */ + if (!gfc_comp_struct (gfc_current_state ())) + { + gfc_error ("Structure name expected in non-nested structure " + "declaration at %C"); + return MATCH_ERROR; + } + /* This is an anonymous structure; make up a unique name for it + (upper-case letters never make it to symbol names from the source). + The important thing is initializing the type variable + and setting gfc_new_symbol, which is immediately used by + parse_structure () and variable_decl () to add components of + this type. */ + snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++); + } + + where = gfc_current_locus; + /* No field list allowed after non-nested structure declaration. */ + if (!gfc_comp_struct (gfc_current_state ()) + && gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after non-nested STRUCTURE statement at %C"); + return MATCH_ERROR; + } + + /* Make sure the name is not the name of an intrinsic type. */ + if (gfc_is_intrinsic_typename (name)) + { + gfc_error ("Structure name '%s' at %C cannot be the same as an" + " intrinsic type", name); + return MATCH_ERROR; + } + + /* Store the actual type symbol for the structure with an upper-case first + letter (an invalid Fortran identifier). */ + + sprintf (name, gfc_dt_upper_string (name)); + if (!get_struct_decl (name, FL_STRUCT, &where, &sym)) + return MATCH_ERROR; + + gfc_new_block = sym; + return MATCH_YES; +} + /* 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. */ @@ -8037,7 +8541,7 @@ gfc_match_derived_decl (void) bool seen_attr = false; gfc_interface *intr = NULL, *head; - if (gfc_current_state () == COMP_DERIVED) + if (gfc_comp_struct (gfc_current_state ())) return MATCH_NO; name[0] = '\0'; @@ -8111,9 +8615,7 @@ gfc_match_derived_decl (void) if (!sym) { /* Use upper case to save the actual derived-type symbol. */ - gfc_get_symbol (gfc_get_string ("%c%s", - (char) TOUPPER ((unsigned char) gensym->name[0]), - &gensym->name[1]), NULL, &sym); + gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym); sym->name = gfc_get_string (gensym->name); head = gensym->generic; intr = gfc_get_interface (); diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 8d50d75fcf6..f50743475d3 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -106,6 +106,7 @@ show_typespec (gfc_typespec *ts) { case BT_DERIVED: case BT_CLASS: + case BT_UNION: fprintf (dumpfile, "%s", ts->u.derived->name); break; diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 1e8be6e4cf7..6ebe08b7538 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -335,7 +335,7 @@ gfc_copy_expr (gfc_expr *p) case BT_HOLLERITH: case BT_LOGICAL: - case BT_DERIVED: + case_bt_struct: case BT_CLASS: case BT_ASSUMED: break; /* Already done. */ @@ -1279,7 +1279,7 @@ find_component_ref (gfc_constructor_base base, gfc_ref *ref) /* For extended types, check if the desired component is in one of the * parent types. */ while (ext > 0 && gfc_find_component (dt->components->ts.u.derived, - pick->name, true, true)) + pick->name, true, true, NULL)) { dt = dt->components->ts.u.derived; c = gfc_constructor_first (c->expr->value.constructor); @@ -1649,7 +1649,7 @@ simplify_const_ref (gfc_expr *p) case AR_FULL: if (p->ref->next != NULL - && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED)) + && (p->ts.type == BT_CHARACTER || gfc_bt_struct (p->ts.type))) { for (c = gfc_constructor_first (p->value.constructor); c; c = gfc_constructor_next (c)) @@ -1659,7 +1659,7 @@ simplify_const_ref (gfc_expr *p) return false; } - if (p->ts.type == BT_DERIVED + if (gfc_bt_struct (p->ts.type) && p->ref->next && (c = gfc_constructor_first (p->value.constructor))) { @@ -3926,9 +3926,9 @@ gfc_has_default_initializer (gfc_symbol *der) { gfc_component *c; - gcc_assert (der->attr.flavor == FL_DERIVED); + gcc_assert (gfc_fl_struct (der->attr.flavor)); for (c = der->components; c; c = c->next) - if (c->ts.type == BT_DERIVED) + if (gfc_bt_struct (c->ts.type)) { if (!c->attr.pointer && !c->attr.proc_pointer && gfc_has_default_initializer (c->ts.u.derived)) @@ -3975,6 +3975,7 @@ gfc_default_initializer (gfc_typespec *ts) if (comp->initializer) { + ctor->n.component = comp; ctor->expr = gfc_copy_expr (comp->initializer); if ((comp->ts.type != comp->initializer->ts.type || comp->ts.kind != comp->initializer->ts.kind) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a0fb5fda9e5..0bb71cb184d 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -62,6 +62,15 @@ not after. #define gfc_is_whitespace(c) ((c==' ') || (c=='\t')) +/* Macros to check for groups of structure-like types and flavors since + derived types, structures, maps, unions are often treated similarly. */ +#define gfc_bt_struct(t) \ + ((t) == BT_DERIVED || (t) == BT_UNION) +#define gfc_fl_struct(f) \ + ((f) == FL_DERIVED || (f) == FL_UNION || (f) == FL_STRUCT) +#define case_bt_struct case BT_DERIVED: case BT_UNION +#define case_fl_struct case FL_DERIVED: case FL_UNION: case FL_STRUCT + /* Stringization. */ #define stringize(x) expand_macro(x) #define expand_macro(x) # x @@ -203,6 +212,8 @@ enum gfc_statement 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_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS, + ST_STRUCTURE_DECL, ST_END_STRUCTURE, + ST_UNION, ST_END_UNION, ST_MAP, ST_END_MAP, ST_OACC_PARALLEL_LOOP, ST_OACC_END_PARALLEL_LOOP, ST_OACC_PARALLEL, ST_OACC_END_PARALLEL, ST_OACC_KERNELS, ST_OACC_END_KERNELS, ST_OACC_DATA, ST_OACC_END_DATA, ST_OACC_HOST_DATA, ST_OACC_END_HOST_DATA, ST_OACC_LOOP, @@ -254,12 +265,12 @@ enum interface_type }; /* Symbol flavors: these are all mutually exclusive. - 10 elements = 4 bits. */ + 12 elements = 4 bits. */ enum sym_flavor { FL_UNKNOWN = 0, FL_PROGRAM, FL_BLOCK_DATA, FL_MODULE, FL_VARIABLE, FL_PARAMETER, FL_LABEL, FL_PROCEDURE, FL_DERIVED, FL_NAMELIST, - FL_VOID + FL_UNION, FL_STRUCT, FL_VOID }; /* Procedure types. 7 elements = 3 bits. */ @@ -2523,6 +2534,8 @@ typedef struct int flag_init_character; char flag_init_character_value; + int flag_dec_structure; + int fpe; int fpe_summary; int rtcheck; @@ -2743,6 +2756,7 @@ bool gfc_check_any_c_kind (gfc_typespec *); int gfc_validate_kind (bt, int, bool); int gfc_get_int_kind_from_width_isofortranenv (int size); int gfc_get_real_kind_from_width_isofortranenv (int size); +tree gfc_get_union_type (gfc_symbol *); tree gfc_get_derived_type (gfc_symbol * derived); extern int gfc_index_integer_kind; extern int gfc_default_integer_kind; @@ -2831,7 +2845,8 @@ int gfc_copy_dummy_sym (gfc_symbol **, gfc_symbol *, int); bool gfc_add_component (gfc_symbol *, const char *, gfc_component **); gfc_symbol *gfc_use_derived (gfc_symbol *); gfc_symtree *gfc_use_derived_tree (gfc_symtree *); -gfc_component *gfc_find_component (gfc_symbol *, const char *, bool, bool); +gfc_component *gfc_find_component (gfc_symbol *, const char *, bool, bool, + gfc_ref **); gfc_st_label *gfc_get_st_label (int); void gfc_free_st_label (gfc_st_label *); @@ -3174,6 +3189,8 @@ void gfc_module_done_2 (void); void gfc_dump_module (const char *, int); bool gfc_check_symbol_access (gfc_symbol *); void gfc_free_use_stmts (gfc_use_list *); +const char *gfc_dt_lower_string (const char *); +const char *gfc_dt_upper_string (const char *); /* primary.c */ symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *); diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 2704bc54978..9d7d3d4b34b 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -474,9 +474,9 @@ The GNU Fortran compiler is able to compile nearly all standard-compliant Fortran 95, Fortran 90, and Fortran 77 programs, including a number of standard and non-standard extensions, and can be used on real-world programs. In particular, the supported extensions -include OpenMP, Cray-style pointers, and several Fortran 2003 and Fortran -2008 features, including TR 15581. However, it is still under -development and has a few remaining rough edges. +include OpenMP, Cray-style pointers, some old vendor extensions, and several +Fortran 2003 and Fortran 2008 features, including TR 15581. However, it is +still under development and has a few remaining rough edges. There also is initial support for OpenACC. Note that this is an experimental feature, incomplete, and subject to change in future versions of GCC. See @@ -1459,6 +1459,8 @@ without warning. * OpenACC:: * Argument list functions:: * Read/Write after EOF marker:: +* STRUCTURE and RECORD:: +* UNION and MAP:: @end menu @node Old-style kind specifications @@ -2117,40 +2119,6 @@ consider @code{BACKSPACE} or @code{REWIND} to properly position the file before the EOF marker. As an extension, the run-time error may be disabled using -std=legacy. -@node Extensions not implemented in GNU Fortran -@section Extensions not implemented in GNU Fortran -@cindex extensions, not implemented - -The long history of the Fortran language, its wide use and broad -userbase, the large number of different compiler vendors and the lack of -some features crucial to users in the first standards have lead to the -existence of a number of important extensions to the language. While -some of the most useful or popular extensions are supported by the GNU -Fortran compiler, not all existing extensions are supported. This section -aims at listing these extensions and offering advice on how best make -code that uses them running with the GNU Fortran compiler. - -@c More can be found here: -@c -- https://gcc.gnu.org/onlinedocs/gcc-3.4.6/g77/Missing-Features.html -@c -- the list of Fortran and libgfortran bugs closed as WONTFIX: -@c http://tinyurl.com/2u4h5y - -@menu -* STRUCTURE and RECORD:: -@c * UNION and MAP:: -* ENCODE and DECODE statements:: -* Variable FORMAT expressions:: -@c * Q edit descriptor:: -@c * AUTOMATIC statement:: -@c * TYPE and ACCEPT I/O Statements:: -@c * .XOR. operator:: -@c * CARRIAGECONTROL, DEFAULTFILE, DISPOSE and RECORDTYPE I/O specifiers:: -@c * Omitted arguments in procedure call:: -* Alternate complex function syntax:: -* Volatile COMMON blocks:: -* OPEN( ... NAME=):: -@end menu - @node STRUCTURE and RECORD @subsection @code{STRUCTURE} and @code{RECORD} @@ -2226,16 +2194,218 @@ store_catalog(12) = pear print *, store_catalog(12) @end example +@noindent +GNU Fortran implements STRUCTURES like derived types with the following +rules and exceptions: + +@itemize @bullet +@item Structures act like derived types with the @code{SEQUENCE} attribute. +Otherwise they may contain no specifiers. + +@item Structures may share names with other symbols. For example, the following +is invalid for derived types, but valid for structures: + +@smallexample +structure /header/ + ! ... +end structure +record /header/ header +@end smallexample + +@item Structure types may be declared nested within another parent structure. +The syntax is: +@smallexample +structure /type-name/ + ... + structure [//] +... +@end smallexample + +The type name may be ommitted, in which case the structure type itself is +anonymous, and other structures of the same type cannot be instantiated. The +following shows some examples: + +@example +structure /appointment/ + ! nested structure definition: app_time is an array of two 'time' + structure /time/ app_time (2) + integer(1) hour, minute + end structure + character(10) memo +end structure + +! The 'time' structure is still usable +record /time/ now +now = time(5, 30) + +... + +structure /appointment/ + ! anonymous nested structure definition + structure start, end + integer(1) hour, minute + end structure + character(10) memo +end structure +@end example + +@item Structures may contain @code{UNION} blocks. For more detail see the +section on @ref{UNION and MAP}. -@c @node UNION and MAP -@c @subsection @code{UNION} and @code{MAP} -@c @cindex @code{UNION} -@c @cindex @code{MAP} -@c -@c For help writing this one, see -@c http://www.eng.umd.edu/~nsw/ench250/fortran1.htm#UNION and -@c http://www.tacc.utexas.edu/services/userguides/pgi/pgiws_ug/pgi32u06.htm +@item Structures support old-style initialization of components, like +those described in @ref{Old-style variable initialization}. For array +initializers, an initializer may contain a repeat specification of the form +@code{ * }. The value of the integer +indicates the number of times to repeat the constant initializer when expanding +the initializer list. +@end itemize + +@node UNION and MAP +@subsection @code{UNION} and @code{MAP} +@cindex @code{UNION} +@cindex @code{MAP} + +Unions are an old vendor extension which were commonly used with the +non-standard @ref{STRUCTURE and RECORD} extensions. Use of @code{UNION} and +@code{MAP} is automatically enabled with @option{-fdec-structure}. + +A @code{UNION} declaration occurs within a structure; within the definition of +each union is a number of @code{MAP} blocks. Each @code{MAP} shares storage +with its sibling maps (in the same union), and the size of the union is the +size of the largest map within it, just as with unions in C. The major +difference is that component references do not indicate which union or map the +component is in (the compiler gets to figure that out). + +Here is a small example: +@smallexample +structure /myunion/ +union + map + integer(2) w, x, y, z + end map + map + integer(4) wx, yz + end map +end union +end structure + +record /myunion/ rec +! After these assignments... +rec.wx = z'0DEDBEEF' +rec.y = z'0BAD' +rec.z = z'0FAD' + +! The following is true: +! rec.w === z'0DED' +! rec.x === z'BEEF' +! rec.yz === z'0BAD0FAD' +@end smallexample + +The two maps share memory, and the size of the union is ultimately six bytes +(subject to alignment): + +@example +0 1 2 3 4 5 6 Byte offset +------------------------------- +| | | | | | | +------------------------------- + +^ W0 ^ W1 ^ W2 ^ + \-------/ \-------/ \-------/ + +^ LONG ^ unused ^ + \-----------------/ \-------/ +@end example + +Following is an example mirroring the layout of an Intel x86_64 register: + +@example +structure /reg/ + union ! rax + map + integer*8 rx ! rax + end map + map + integer*4 rh ! rah + union ! eax + map + integer*4 rl ! ral + end map + map + integer*4 ex ! eax + end map + map + integer*2 eh ! eah + union ! ax + map + integer*2 el ! eal + end map + map + integer*2 x ! ax + end map + map + integer*1 h ! ah + integer*1 l ! al + end map + end union ! ax + end map + end union ! eax + end map + end union ! rax +end structure + +record /reg/ a + +! After this assignment... +a.rx = z'AABBCCCCFFFFFFFF' + +! The following is true: +! +! a.rx == z'AABBCCCCFFFFFFFF' +! a.rh == z'FFFFFFFF' +! a.rl == z'AABBCCCC' +! +! a.ex == z'AABBCCCC' +! a.eh == z'CCCC' +! a.el == z'AABB' +! +! a.x == z'AABB' +! a.h == z'BB' +! a.l == z'AA' +@end example + + +@node Extensions not implemented in GNU Fortran +@section Extensions not implemented in GNU Fortran +@cindex extensions, not implemented + +The long history of the Fortran language, its wide use and broad +userbase, the large number of different compiler vendors and the lack of +some features crucial to users in the first standards have lead to the +existence of a number of important extensions to the language. While +some of the most useful or popular extensions are supported by the GNU +Fortran compiler, not all existing extensions are supported. This section +aims at listing these extensions and offering advice on how best make +code that uses them running with the GNU Fortran compiler. +@c More can be found here: +@c -- https://gcc.gnu.org/onlinedocs/gcc-3.4.6/g77/Missing-Features.html +@c -- the list of Fortran and libgfortran bugs closed as WONTFIX: +@c http://tinyurl.com/2u4h5y + +@menu +* ENCODE and DECODE statements:: +* Variable FORMAT expressions:: +@c * Q edit descriptor:: +@c * AUTOMATIC statement:: +@c * TYPE and ACCEPT I/O Statements:: +@c * .XOR. operator:: +@c * CARRIAGECONTROL, DEFAULTFILE, DISPOSE and RECORDTYPE I/O specifiers:: +@c * Omitted arguments in procedure call:: +* Alternate complex function syntax:: +* Volatile COMMON blocks:: +* OPEN( ... NAME=):: +@end menu @node ENCODE and DECODE statements @subsection @code{ENCODE} and @code{DECODE} statements @@ -2355,7 +2525,6 @@ invalid standard Fortran syntax and is not supported by @code{VOLATILE} variables in @code{COMMON} blocks since revision 4.3. - @node OPEN( ... NAME=) @subsection @code{OPEN( ... NAME=)} @cindex @code{NAM} diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 5c66c6ef31c..b981e7c0991 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -387,19 +387,147 @@ gfc_match_end_interface (void) } +/* Compare components according to 4.4.2 of the Fortran standard. */ + +static int +compare_components (gfc_component *cmp1, gfc_component *cmp2, + gfc_symbol *derived1, gfc_symbol *derived2) +{ + gfc_symbol *d1, *d2; + bool anonymous = false; + + /* Unions, maps, and anonymous structures all have names like "[xX]X$\d+" + which should not be compared. */ + d1 = cmp1->ts.u.derived; + d2 = cmp2->ts.u.derived; + if ( (d1 && (d1->attr.flavor == FL_STRUCT || d1->attr.flavor == FL_UNION) + && ISUPPER (cmp1->name[1])) + || (d2 && (d2->attr.flavor == FL_STRUCT || d2->attr.flavor == FL_UNION) + && ISUPPER (cmp1->name[1]))) + anonymous = true; + + if (!anonymous && strcmp (cmp1->name, cmp2->name) != 0) + return 0; + + if (cmp1->attr.access != cmp2->attr.access) + return 0; + + if (cmp1->attr.pointer != cmp2->attr.pointer) + return 0; + + if (cmp1->attr.dimension != cmp2->attr.dimension) + return 0; + + if (cmp1->attr.allocatable != cmp2->attr.allocatable) + return 0; + + if (cmp1->attr.dimension && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0) + return 0; + + /* Make sure that link lists do not put this function into an + endless recursive loop! */ + if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived) + && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived) + && gfc_compare_types (&cmp1->ts, &cmp2->ts) == 0) + return 0; + + else if ( (cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived) + && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived)) + return 0; + + else if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived) + && (cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived)) + return 0; + + return 1; +} + + +/* Compare two union types by comparing the components of their maps. + Because unions and maps are anonymous their types get special internal + names; therefore the usual derived type comparison will fail on them. + + Returns nonzero if equal, as with gfc_compare_derived_types. Also as with + gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate + definitions' than 'equivalent structure'. */ + +int +gfc_compare_union_types (gfc_symbol *un1, gfc_symbol *un2) +{ + gfc_component *map1, *map2, *cmp1, *cmp2; + + if (un1->attr.flavor != FL_UNION || un2->attr.flavor != FL_UNION) + return 0; + + map1 = un1->components; + map2 = un2->components; + + /* In terms of 'equality' here we are worried about types which are + declared the same in two places, not types that represent equivalent + structures. (This is common because of FORTRAN's weird scoping rules.) + Though two unions with their maps in different orders could be equivalent, + we will say they are not equal for the purposes of this test; therefore + we compare the maps sequentially. */ + for (;;) + { + cmp1 = map1->ts.u.derived->components; + cmp2 = map2->ts.u.derived->components; + for (;;) + { + /* No two fields will ever point to the same map type unless they are + the same component, because one map field is created with its type + declaration. Therefore don't worry about recursion here. */ + /* TODO: worry about recursion into parent types of the unions? */ + if (compare_components (cmp1, cmp2, + map1->ts.u.derived, map2->ts.u.derived) == 0) + return 0; + + cmp1 = cmp1->next; + cmp2 = cmp2->next; + + if (cmp1 == NULL && cmp2 == NULL) + break; + if (cmp1 == NULL || cmp2 == NULL) + return 0; + } + + map1 = map1->next; + map2 = map2->next; + + if (map1 == NULL && map2 == NULL) + break; + if (map1 == NULL || map2 == NULL) + return 0; + } + + return 1; +} + + + /* Compare two derived types using the criteria in 4.4.2 of the standard, recursing through gfc_compare_types for the components. */ int gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) { - gfc_component *dt1, *dt2; + gfc_component *cmp1, *cmp2; + bool anonymous = false; if (derived1 == derived2) return 1; gcc_assert (derived1 && derived2); + /* MAP and anonymous STRUCTURE types have internal names of the form + mM* and sS* (we can get away this this because source names are converted + to lowerase). Compare anonymous type names specially because each + gets a unique name when it is declared. */ + anonymous = (derived1->name[0] == derived2->name[0] + && derived1->name[1] && derived2->name[1] && derived2->name[2] + && derived1->name[1] == (char) TOUPPER (derived1->name[0]) + && derived2->name[2] == (char) TOUPPER (derived2->name[0])); + /* 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. */ @@ -409,9 +537,11 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) return 1; /* Compare type via the rules of the standard. Both types must have - the SEQUENCE or BIND(C) attribute to be equal. */ + the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special + because they can be anonymous; therefore two structures with different + names may be equal. */ - if (strcmp (derived1->name, derived2->name)) + if (strcmp (derived1->name, derived2->name) != 0 && !anonymous) return 0; if (derived1->component_access == ACCESS_PRIVATE @@ -422,53 +552,30 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c)) return 0; - dt1 = derived1->components; - dt2 = derived2->components; + /* Protect against null components. */ + if (derived1->attr.zero_comp != derived2->attr.zero_comp) + return 0; + + if (derived1->attr.zero_comp) + return 1; + + cmp1 = derived1->components; + cmp2 = derived2->components; /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a simple test can speed things up. Otherwise, lots of things have to match. */ for (;;) { - if (strcmp (dt1->name, dt2->name) != 0) - return 0; - - if (dt1->attr.access != dt2->attr.access) - return 0; - - if (dt1->attr.pointer != dt2->attr.pointer) - return 0; - - if (dt1->attr.dimension != dt2->attr.dimension) - return 0; + if (!compare_components (cmp1, cmp2, derived1, derived2)) + return 0; - if (dt1->attr.allocatable != dt2->attr.allocatable) - return 0; - - if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0) - return 0; - - /* Make sure that link lists do not put this function into an - endless recursive loop! */ - if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived) - && !(dt2->ts.type == BT_DERIVED && derived2 == dt2->ts.u.derived) - && gfc_compare_types (&dt1->ts, &dt2->ts) == 0) - return 0; + cmp1 = cmp1->next; + cmp2 = cmp2->next; - else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived) - && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)) - return 0; - - else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived) - && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)) - return 0; - - dt1 = dt1->next; - dt2 = dt2->next; - - if (dt1 == NULL && dt2 == NULL) + if (cmp1 == NULL && cmp2 == NULL) break; - if (dt1 == NULL || dt2 == NULL) + if (cmp1 == NULL || cmp2 == NULL) return 0; } @@ -509,18 +616,18 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) && (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c)) return 1; + if (ts1->type == BT_UNION && ts2->type == BT_UNION) + return gfc_compare_union_types (ts1->u.derived, ts2->u.derived); + if (ts1->type != ts2->type - && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS) - || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS))) + && ((!gfc_bt_struct (ts1->type) && ts1->type != BT_CLASS) + || (!gfc_bt_struct (ts2->type) && ts2->type != BT_CLASS))) return 0; if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS) return (ts1->kind == ts2->kind); /* Compare derived types. */ - if (gfc_type_compatible (ts1, ts2)) - return 1; - - return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived); + return gfc_type_compatible (ts1, ts2); } @@ -1585,7 +1692,7 @@ check_interface0 (gfc_interface *p, const char *interface_name) functions or subroutines. */ if (((!p->sym->attr.function && !p->sym->attr.subroutine) || !p->sym->attr.if_source) - && p->sym->attr.flavor != FL_DERIVED) + && !gfc_fl_struct (p->sym->attr.flavor)) { if (p->sym->attr.external) gfc_error ("Procedure %qs in %s at %L has no explicit interface", @@ -1599,14 +1706,14 @@ check_interface0 (gfc_interface *p, const char *interface_name) /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */ if ((psave->sym->attr.function && !p->sym->attr.function - && p->sym->attr.flavor != FL_DERIVED) + && !gfc_fl_struct (p->sym->attr.flavor)) || (psave->sym->attr.subroutine && !p->sym->attr.subroutine)) { - if (p->sym->attr.flavor != FL_DERIVED) + if (!gfc_fl_struct (p->sym->attr.flavor)) gfc_error ("In %s at %L procedures must be either all SUBROUTINEs" " or all FUNCTIONs", interface_name, &p->sym->declared_at); - else + else if (p->sym->attr.flavor == FL_DERIVED) gfc_error ("In %s at %L procedures must be all FUNCTIONs as the " "generic name is also the name of a derived type", interface_name, &p->sym->declared_at); @@ -1666,8 +1773,8 @@ check_interface1 (gfc_interface *p, gfc_interface *q0, if (p->sym->name == q->sym->name && p->sym->module == q->sym->module) continue; - if (p->sym->attr.flavor != FL_DERIVED - && q->sym->attr.flavor != FL_DERIVED + if (!gfc_fl_struct (p->sym->attr.flavor) + && !gfc_fl_struct (q->sym->attr.flavor) && gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag, 0, NULL, 0, NULL, NULL)) { @@ -3550,7 +3657,7 @@ gfc_search_interface (gfc_interface *intr, int sub_flag, for (; intr; intr = intr->next) { - if (intr->sym->attr.flavor == FL_DERIVED) + if (gfc_fl_struct (intr->sym->attr.flavor)) continue; if (sub_flag && intr->sym->attr.function) continue; diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index e90656e4eef..e8b8409319e 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -115,7 +115,8 @@ by type. Explanations are in the following sections. @item Fortran Language Options @xref{Fortran Dialect Options,,Options controlling Fortran dialect}. @gccoptlist{-fall-intrinsics -fbackslash -fcray-pointer -fd-lines-as-code @gol --fd-lines-as-comments -fdefault-double-8 -fdefault-integer-8 @gol +-fd-lines-as-comments @gol +-fdec -fdec-structure -fdefault-double-8 -fdefault-integer-8 @gol -fdefault-real-8 -fdollar-ok -ffixed-line-length-@var{n} @gol -ffixed-line-length-none -ffree-form -ffree-line-length-@var{n} @gol -ffree-line-length-none -fimplicit-none -finteger-4-integer-8 @gol @@ -228,6 +229,24 @@ given they are treated as if the first column contained a blank. If the @option{-fd-lines-as-comments} option is given, they are treated as comment lines. +@item -fdec +@opindex @code{fdec} +DEC compatibility mode. Enables extensions and other features that mimic +the default behavior of older compilers (such as DEC). +These features are non-standard and should be avoided at all costs. +For details on GNU Fortran's implementation of these extensions see the +full documentation. + +Other flags enabled by this switch are: +@option{-fdollar-ok} @option{-fcray-pointer} @option{-fdec-structure} + +@item -fdec-structure +@opindex @code{fdec-structure} +Enable DEC @code{STRUCTURE} and @code{RECORD} as well as @code{UNION}, +@code{MAP}, and dot ('.') as a member separator (in addition to '%'). This is +provided for compatibility only; Fortran 90 derived types should be used +instead where possible. + @item -fdollar-ok @opindex @code{fdollar-ok} @cindex @code{$} diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 45428d8cf41..bdf5fa5fb4a 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -416,6 +416,14 @@ fd-lines-as-comments Fortran RejectNegative Treat lines with 'D' in column one as comments. +fdec +Fortran +Enable all DEC language extensions. + +fdec-structure +Fortran +Enable support for DEC STRUCTURE/RECORD. + fdefault-double-8 Fortran Var(flag_default_double) Set the default double precision kind to an 8 byte wide type. diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 96063f796d0..e9132506367 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -164,6 +164,6 @@ typedef enum typedef enum { BT_UNKNOWN = 0, BT_INTEGER, BT_LOGICAL, BT_REAL, BT_COMPLEX, BT_DERIVED, BT_CHARACTER, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID, - BT_ASSUMED + BT_ASSUMED, BT_UNION } bt; diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 2490f85626e..f3a4a43a34c 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -113,6 +113,128 @@ gfc_op2string (gfc_intrinsic_op op) /******************** Generic matching subroutines ************************/ +/* Matches a member separator. With standard FORTRAN this is '%', but with + DEC structures we must carefully match dot ('.'). + Because operators are spelled ".op.", a dotted string such as "x.y.z..." + can be either a component reference chain or a combination of binary + operations. + There is no real way to win because the string may be grammatically + ambiguous. The following rules help avoid ambiguities - they match + some behavior of other (older) compilers. If the rules here are changed + the test cases should be updated. If the user has problems with these rules + they probably deserve the consequences. Consider "x.y.z": + (1) If any user defined operator ".y." exists, this is always y(x,z) + (even if ".y." is the wrong type and/or x has a member y). + (2) Otherwise if x has a member y, and y is itself a derived type, + this is (x->y)->z, even if an intrinsic operator exists which + can handle (x,z). + (3) If x has no member y or (x->y) is not a derived type but ".y." + is an intrinsic operator (such as ".eq."), this is y(x,z). + (4) Lastly if there is no operator ".y." and x has no member "y", it is an + error. + It is worth noting that the logic here does not support mixed use of member + accessors within a single string. That is, even if x has component y and y + has component z, the following are all syntax errors: + "x%y.z" "x.y%z" "(x.y).z" "(x%y)%z" + */ + +match +gfc_match_member_sep(gfc_symbol *sym) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + locus dot_loc, start_loc; + gfc_intrinsic_op iop; + match m; + gfc_symbol *tsym; + gfc_component *c = NULL; + + /* What a relief: '%' is an unambiguous member separator. */ + if (gfc_match_char ('%') == MATCH_YES) + return MATCH_YES; + + /* Beware ye who enter here. */ + if (!gfc_option.flag_dec_structure || !sym) + return MATCH_NO; + + tsym = NULL; + + /* We may be given either a derived type variable or the derived type + declaration itself (which actually contains the components); + we need the latter to search for components. */ + if (gfc_fl_struct (sym->attr.flavor)) + tsym = sym; + else if (gfc_bt_struct (sym->ts.type)) + tsym = sym->ts.u.derived; + + iop = INTRINSIC_NONE; + name[0] = '\0'; + m = MATCH_NO; + + /* If we have to reject come back here later. */ + start_loc = gfc_current_locus; + + /* Look for a component access next. */ + if (gfc_match_char ('.') != MATCH_YES) + return MATCH_NO; + + /* If we accept, come back here. */ + dot_loc = gfc_current_locus; + + /* Try to match a symbol name following the dot. */ + if (gfc_match_name (name) != MATCH_YES) + { + gfc_error ("Expected structure component or operator name " + "after '.' at %C"); + goto error; + } + + /* If no dot follows we have "x.y" which should be a component access. */ + if (gfc_match_char ('.') != MATCH_YES) + goto yes; + + /* Now we have a string "x.y.z" which could be a nested member access + (x->y)->z or a binary operation y on x and z. */ + + /* First use any user-defined operators ".y." */ + if (gfc_find_uop (name, sym->ns) != NULL) + goto no; + + /* Match accesses to existing derived-type components for + derived-type vars: "x.y.z" = (x->y)->z */ + c = gfc_find_component(tsym, name, false, true, NULL); + if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS)) + goto yes; + + /* If y is not a component or has no members, try intrinsic operators. */ + gfc_current_locus = start_loc; + if (gfc_match_intrinsic_op (&iop) != MATCH_YES) + { + /* If ".y." is not an intrinsic operator but y was a valid non- + structure component, match and leave the trailing dot to be + dealt with later. */ + if (c) + goto yes; + + gfc_error ("'%s' is neither a defined operator nor a " + "structure component in dotted string at %C", name); + goto error; + } + + /* .y. is an intrinsic operator, overriding any possible member access. */ + goto no; + + /* Return keeping the current locus consistent with the match result. */ +error: + m = MATCH_ERROR; +no: + gfc_current_locus = start_loc; + return m; +yes: + gfc_current_locus = dot_loc; + return MATCH_YES; +} + + /* This function scans the current statement counting the opened and closed parenthesis to make sure they are balanced. */ diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index c3033add826..348ca701c92 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -60,6 +60,7 @@ match gfc_match (const char *, ...); match gfc_match_iterator (gfc_iterator *, int); match gfc_match_parens (void); match gfc_match_type_spec (gfc_typespec *); +match gfc_match_member_sep(gfc_symbol *); /* Statement matchers. */ @@ -208,6 +209,9 @@ match gfc_match_function_decl (void); match gfc_match_entry (void); match gfc_match_subroutine (void); match gfc_match_submod_proc (void); +match gfc_match_map (void); +match gfc_match_union (void); +match gfc_match_structure_decl (void); match gfc_match_derived_decl (void); match gfc_match_final_decl (void); diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c index 405bae072ba..1747ff2ac74 100644 --- a/gcc/fortran/misc.c +++ b/gcc/fortran/misc.c @@ -83,6 +83,9 @@ gfc_basic_typename (bt type) case BT_HOLLERITH: p = "HOLLERITH"; break; + case BT_UNION: + p = "UNION"; + break; case BT_DERIVED: p = "DERIVED"; break; @@ -144,6 +147,9 @@ gfc_typename (gfc_typespec *ts) case BT_HOLLERITH: sprintf (buffer, "HOLLERITH"); break; + case BT_UNION: + sprintf (buffer, "UNION(%s)", ts->u.derived->name); + break; case BT_DERIVED: sprintf (buffer, "TYPE(%s)", ts->u.derived->name); break; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 32ee526aa22..6d3860ef826 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -422,8 +422,8 @@ resolve_fixups (fixup_t *f, void *gp) to convert the symtree name of a derived-type to the symbol name or to the name of the associated generic function. */ -static const char * -dt_lower_string (const char *name) +const char * +gfc_dt_lower_string (const char *name) { if (name[0] != (char) TOLOWER ((unsigned char) name[0])) return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]), @@ -437,8 +437,8 @@ dt_lower_string (const char *name) symtree/symbol name of the associated generic function start with a lower- case character. */ -static const char * -dt_upper_string (const char *name) +const char * +gfc_dt_upper_string (const char *name) { if (name[0] != (char) TOUPPER ((unsigned char) name[0])) return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]), @@ -832,7 +832,7 @@ find_use_name_n (const char *name, int *inst, bool interface) /* For derived types. */ if (name[0] != (char) TOLOWER ((unsigned char) name[0])) - low_name = dt_lower_string (name); + low_name = gfc_dt_lower_string (name); i = 0; for (u = gfc_rename_list; u; u = u->next) @@ -861,7 +861,7 @@ find_use_name_n (const char *name, int *inst, bool interface) { if (u->local_name[0] == '\0') return name; - return dt_upper_string (u->local_name); + return gfc_dt_upper_string (u->local_name); } return (u->local_name[0] != '\0') ? u->local_name : name; @@ -989,8 +989,8 @@ add_true_name (gfc_symbol *sym) t = XCNEW (true_name); t->sym = sym; - if (sym->attr.flavor == FL_DERIVED) - t->name = dt_upper_string (sym->name); + if (gfc_fl_struct (sym->attr.flavor)) + t->name = gfc_dt_upper_string (sym->name); else t->name = sym->name; @@ -1011,8 +1011,8 @@ build_tnt (gfc_symtree *st) build_tnt (st->left); build_tnt (st->right); - if (st->n.sym->attr.flavor == FL_DERIVED) - name = dt_upper_string (st->n.sym->name); + if (gfc_fl_struct (st->n.sym->attr.flavor)) + name = gfc_dt_upper_string (st->n.sym->name); else name = st->n.sym->name; @@ -2452,6 +2452,7 @@ static const mstring bt_types[] = { minit ("COMPLEX", BT_COMPLEX), minit ("LOGICAL", BT_LOGICAL), minit ("CHARACTER", BT_CHARACTER), + minit ("UNION", BT_UNION), minit ("DERIVED", BT_DERIVED), minit ("CLASS", BT_CLASS), minit ("PROCEDURE", BT_PROCEDURE), @@ -2505,7 +2506,7 @@ mio_typespec (gfc_typespec *ts) ts->type = MIO_NAME (bt) (ts->type, bt_types); - if (ts->type != BT_DERIVED && ts->type != BT_CLASS) + if (!gfc_bt_struct (ts->type) && ts->type != BT_CLASS) mio_integer (&ts->kind); else mio_symbol_ref (&ts->u.derived); @@ -3322,8 +3323,8 @@ fix_mio_expr (gfc_expr *e) if (e->symtree->n.sym && check_unique_name (e->symtree->name)) { const char *name = e->symtree->n.sym->name; - if (e->symtree->n.sym->attr.flavor == FL_DERIVED) - name = dt_upper_string (name); + if (gfc_fl_struct (e->symtree->n.sym->attr.flavor)) + name = gfc_dt_upper_string (name); ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name); } @@ -4265,7 +4266,7 @@ mio_symbol (gfc_symbol *sym) mio_integer (&(sym->intmod_sym_id)); - if (sym->attr.flavor == FL_DERIVED) + if (gfc_fl_struct (sym->attr.flavor)) mio_integer (&(sym->hash_value)); if (sym->formal_ns @@ -4845,7 +4846,7 @@ load_needed (pointer_info *p) 1, &ns->proc_name); sym = gfc_new_symbol (p->u.rsym.true_name, ns); - sym->name = dt_lower_string (p->u.rsym.true_name); + sym->name = gfc_dt_lower_string (p->u.rsym.true_name); sym->module = gfc_get_string (p->u.rsym.module); if (p->u.rsym.binding_label) sym->binding_label = IDENTIFIER_POINTER (get_identifier @@ -4857,6 +4858,12 @@ load_needed (pointer_info *p) mio_symbol (sym); sym->attr.use_assoc = 1; + /* Unliked derived types, a STRUCTURE may share names with other symbols. + We greedily converted the the symbol name to lowercase before we knew its + type, so now we must fix it. */ + if (sym->attr.flavor == FL_STRUCT) + sym->name = gfc_dt_upper_string (sym->name); + /* Mark as only or rename for later diagnosis for explicitly imported but not used warnings; don't mark internal symbols such as __vtab, __def_init etc. Only mark them if they have been explicitly loaded. */ @@ -5059,7 +5066,7 @@ read_module (void) can be used in expressions in the module. To avoid the module loading failing, we need to associate the module's component pointer indexes with the existing symbol's component pointers. */ - if (sym->attr.flavor == FL_DERIVED) + if (gfc_fl_struct (sym->attr.flavor)) { gfc_component *c; @@ -5213,7 +5220,7 @@ read_module (void) { info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns); - info->u.rsym.sym->name = dt_lower_string (info->u.rsym.true_name); + info->u.rsym.sym->name = gfc_dt_lower_string (info->u.rsym.true_name); sym = info->u.rsym.sym; sym->module = gfc_get_string (info->u.rsym.module); @@ -5557,10 +5564,10 @@ write_symbol (int n, gfc_symbol *sym) mio_integer (&n); - if (sym->attr.flavor == FL_DERIVED) + if (gfc_fl_struct (sym->attr.flavor)) { const char *name; - name = dt_upper_string (sym->name); + name = gfc_dt_upper_string (sym->name); mio_pool_string (&name); } else @@ -6568,7 +6575,7 @@ create_derived_type (const char *name, const char *modname, sym->attr.function = 1; sym->attr.generic = 1; - gfc_get_sym_tree (dt_upper_string (sym->name), + gfc_get_sym_tree (gfc_dt_upper_string (sym->name), gfc_current_ns, &tmp_symtree, false); dt_sym = tmp_symtree->n.sym; dt_sym->name = gfc_get_string (sym->name); diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index 0fcda1d4840..5a91ec1b209 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -47,6 +47,15 @@ set_default_std_flags (void) } +/* Set all the DEC extension flags. */ + +static void +set_dec_flags (int value) +{ + gfc_option.flag_dec_structure = value; +} + + /* Return language mask for Fortran options. */ unsigned int @@ -102,6 +111,8 @@ gfc_init_options (unsigned int decoded_options_count, if (!global_options_set.x_cpp_warn_missing_include_dirs) global_options.x_cpp_warn_missing_include_dirs = 1; + set_dec_flags (0); + set_default_std_flags (); /* Initialize cpp-related options. */ @@ -709,6 +720,15 @@ gfc_handle_option (size_t scode, const char *arg, int value, case OPT_fcheck_: gfc_handle_runtime_check_option (arg); break; + + case OPT_fdec: + /* Enable all DEC extensions. */ + set_dec_flags (1); + break; + + case OPT_fdec_structure: + gfc_option.flag_dec_structure = 1; + break; } Fortran_handle_option_auto (&global_options, &global_options_set, diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 7bce47fef0a..dd7aa6a4e13 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -256,6 +256,7 @@ decode_specification_statement (void) case 's': match ("save", gfc_match_save, ST_ATTR_DECL); + match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL); break; case 't': @@ -507,6 +508,7 @@ decode_statement (void) break; case 'm': + match ("map", gfc_match_map, ST_MAP); match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC); match ("module", gfc_match_module, ST_MODULE); break; @@ -542,6 +544,7 @@ decode_statement (void) break; case 's': + match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL); match ("sequence", gfc_match_eos, ST_SEQUENCE); match ("stop", gfc_match_stop, ST_STOP); match ("save", gfc_match_save, ST_ATTR_DECL); @@ -558,6 +561,7 @@ decode_statement (void) break; case 'u': + match ("union", gfc_match_union, ST_UNION); match ("unlock", gfc_match_unlock, ST_UNLOCK); break; @@ -1642,6 +1646,15 @@ gfc_ascii_statement (gfc_statement st) case ST_DEALLOCATE: p = "DEALLOCATE"; break; + case ST_MAP: + p = "MAP"; + break; + case ST_UNION: + p = "UNION"; + break; + case ST_STRUCTURE_DECL: + p = "STRUCTURE"; + break; case ST_DERIVED_DECL: p = _("derived type declaration"); break; @@ -1711,6 +1724,15 @@ gfc_ascii_statement (gfc_statement st) case ST_END_WHERE: p = "END WHERE"; break; + case ST_END_STRUCTURE: + p = "END STRUCTURE"; + break; + case ST_END_UNION: + p = "END UNION"; + break; + case ST_END_MAP: + p = "END MAP"; + break; case ST_END_TYPE: p = "END TYPE"; break; @@ -2457,6 +2479,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent) case ST_PUBLIC: case ST_PRIVATE: + case ST_STRUCTURE_DECL: case ST_DERIVED_DECL: case_decl: if (p->state >= ORDER_EXEC) @@ -2646,6 +2669,358 @@ error: } +/* Set attributes for the parent symbol based on the attributes of a component + and raise errors if conflicting attributes are found for the component. */ + +static void +check_component (gfc_symbol *sym, gfc_component *c, gfc_component **lockp, + gfc_component **eventp) +{ + bool coarray, lock_type, event_type, allocatable, pointer; + coarray = lock_type = event_type = allocatable = pointer = false; + gfc_component *lock_comp = NULL, *event_comp = NULL; + + if (lockp) lock_comp = *lockp; + if (eventp) event_comp = *eventp; + + /* Look for allocatable components. */ + if (c->attr.allocatable + || (c->ts.type == BT_CLASS && c->attr.class_ok + && CLASS_DATA (c)->attr.allocatable) + || (c->ts.type == BT_DERIVED && !c->attr.pointer + && c->ts.u.derived->attr.alloc_comp)) + { + allocatable = true; + sym->attr.alloc_comp = 1; + } + + /* Look for pointer components. */ + if (c->attr.pointer + || (c->ts.type == BT_CLASS && c->attr.class_ok + && CLASS_DATA (c)->attr.class_pointer) + || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp)) + { + pointer = true; + sym->attr.pointer_comp = 1; + } + + /* Look for procedure pointer components. */ + if (c->attr.proc_pointer + || (c->ts.type == BT_DERIVED + && c->ts.u.derived->attr.proc_pointer_comp)) + sym->attr.proc_pointer_comp = 1; + + /* Looking for coarray components. */ + if (c->attr.codimension + || (c->ts.type == BT_CLASS && c->attr.class_ok + && CLASS_DATA (c)->attr.codimension)) + { + coarray = true; + sym->attr.coarray_comp = 1; + } + + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp + && !c->attr.pointer) + { + coarray = true; + sym->attr.coarray_comp = 1; + } + + /* Looking for lock_type components. */ + if ((c->ts.type == BT_DERIVED + && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) + || (c->ts.type == BT_CLASS && c->attr.class_ok + && CLASS_DATA (c)->ts.u.derived->from_intmod + == INTMOD_ISO_FORTRAN_ENV + && CLASS_DATA (c)->ts.u.derived->intmod_sym_id + == ISOFORTRAN_LOCK_TYPE) + || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp + && !allocatable && !pointer)) + { + lock_type = 1; + lock_comp = c; + sym->attr.lock_comp = 1; + } + + /* Looking for event_type components. */ + if ((c->ts.type == BT_DERIVED + && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) + || (c->ts.type == BT_CLASS && c->attr.class_ok + && CLASS_DATA (c)->ts.u.derived->from_intmod + == INTMOD_ISO_FORTRAN_ENV + && CLASS_DATA (c)->ts.u.derived->intmod_sym_id + == ISOFORTRAN_EVENT_TYPE) + || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp + && !allocatable && !pointer)) + { + event_type = 1; + event_comp = c; + sym->attr.event_comp = 1; + } + + /* Check for F2008, C1302 - and recall that pointers may not be coarrays + (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7), + unless there are nondirect [allocatable or pointer] components + involved (cf. 1.3.33.1 and 1.3.33.3). */ + + if (pointer && !coarray && lock_type) + gfc_error ("Component %s at %L of type LOCK_TYPE must have a " + "codimension or be a subcomponent of a coarray, " + "which is not possible as the component has the " + "pointer attribute", c->name, &c->loc); + else if (pointer && !coarray && c->ts.type == BT_DERIVED + && c->ts.u.derived->attr.lock_comp) + gfc_error ("Pointer component %s at %L has a noncoarray subcomponent " + "of type LOCK_TYPE, which must have a codimension or be a " + "subcomponent of a coarray", c->name, &c->loc); + + if (lock_type && allocatable && !coarray) + gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have " + "a codimension", c->name, &c->loc); + else if (lock_type && allocatable && c->ts.type == BT_DERIVED + && c->ts.u.derived->attr.lock_comp) + gfc_error ("Allocatable component %s at %L must have a codimension as " + "it has a noncoarray subcomponent of type LOCK_TYPE", + c->name, &c->loc); + + if (sym->attr.coarray_comp && !coarray && lock_type) + gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with " + "subcomponent of type LOCK_TYPE must have a codimension or " + "be a subcomponent of a coarray. (Variables of type %s may " + "not have a codimension as already a coarray " + "subcomponent exists)", c->name, &c->loc, sym->name); + + if (sym->attr.lock_comp && coarray && !lock_type) + gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with " + "subcomponent of type LOCK_TYPE must have a codimension or " + "be a subcomponent of a coarray. (Variables of type %s may " + "not have a codimension as %s at %L has a codimension or a " + "coarray subcomponent)", lock_comp->name, &lock_comp->loc, + sym->name, c->name, &c->loc); + + /* Similarly for EVENT TYPE. */ + + if (pointer && !coarray && event_type) + gfc_error ("Component %s at %L of type EVENT_TYPE must have a " + "codimension or be a subcomponent of a coarray, " + "which is not possible as the component has the " + "pointer attribute", c->name, &c->loc); + else if (pointer && !coarray && c->ts.type == BT_DERIVED + && c->ts.u.derived->attr.event_comp) + gfc_error ("Pointer component %s at %L has a noncoarray subcomponent " + "of type EVENT_TYPE, which must have a codimension or be a " + "subcomponent of a coarray", c->name, &c->loc); + + if (event_type && allocatable && !coarray) + gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have " + "a codimension", c->name, &c->loc); + else if (event_type && allocatable && c->ts.type == BT_DERIVED + && c->ts.u.derived->attr.event_comp) + gfc_error ("Allocatable component %s at %L must have a codimension as " + "it has a noncoarray subcomponent of type EVENT_TYPE", + c->name, &c->loc); + + if (sym->attr.coarray_comp && !coarray && event_type) + gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with " + "subcomponent of type EVENT_TYPE must have a codimension or " + "be a subcomponent of a coarray. (Variables of type %s may " + "not have a codimension as already a coarray " + "subcomponent exists)", c->name, &c->loc, sym->name); + + if (sym->attr.event_comp && coarray && !event_type) + gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with " + "subcomponent of type EVENT_TYPE must have a codimension or " + "be a subcomponent of a coarray. (Variables of type %s may " + "not have a codimension as %s at %L has a codimension or a " + "coarray subcomponent)", event_comp->name, &event_comp->loc, + sym->name, c->name, &c->loc); + + /* Look for private components. */ + if (sym->component_access == ACCESS_PRIVATE + || c->attr.access == ACCESS_PRIVATE + || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp)) + sym->attr.private_comp = 1; + + if (lockp) *lockp = lock_comp; + if (eventp) *eventp = event_comp; +} + + +static void parse_struct_map (gfc_statement); + +/* Parse a union component definition within a structure definition. */ + +static void +parse_union (void) +{ + int compiling; + gfc_statement st; + gfc_state_data s; + gfc_component *c, *lock_comp = NULL, *event_comp = NULL; + gfc_symbol *un; + + accept_statement(ST_UNION); + push_state (&s, COMP_UNION, gfc_new_block); + un = gfc_new_block; + + compiling = 1; + + while (compiling) + { + st = next_statement (); + /* Only MAP declarations valid within a union. */ + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_MAP: + accept_statement (ST_MAP); + parse_struct_map (ST_MAP); + /* Add a component to the union for each map. */ + if (!gfc_add_component (un, gfc_new_block->name, &c)) + { + gfc_internal_error ("failed to create map component '%s'", + gfc_new_block->name); + reject_statement (); + return; + } + c->ts.type = BT_DERIVED; + c->ts.u.derived = gfc_new_block; + /* Normally components get their initialization expressions when they + are created in decl.c (build_struct) so we can look through the + flat component list for initializers during resolution. Unions and + maps create components along with their type definitions so we + have to generate initializers here. */ + c->initializer = gfc_default_initializer (&c->ts); + break; + + case ST_END_UNION: + compiling = 0; + accept_statement (ST_END_UNION); + break; + + default: + unexpected_statement (st); + break; + } + } + + for (c = un->components; c; c = c->next) + check_component (un, c, &lock_comp, &event_comp); + + /* Add the union as a component in its parent structure. */ + pop_state (); + if (!gfc_add_component (gfc_current_block (), un->name, &c)) + { + gfc_internal_error ("failed to create union component '%s'", un->name); + reject_statement (); + return; + } + c->ts.type = BT_UNION; + c->ts.u.derived = un; + c->initializer = gfc_default_initializer (&c->ts); + + un->attr.zero_comp = un->components == NULL; +} + + +/* Parse a STRUCTURE or MAP. */ + +static void +parse_struct_map (gfc_statement block) +{ + int compiling_type; + gfc_statement st; + gfc_state_data s; + gfc_symbol *sym; + gfc_component *c, *lock_comp = NULL, *event_comp = NULL; + gfc_compile_state comp; + gfc_statement ends; + + if (block == ST_STRUCTURE_DECL) + { + comp = COMP_STRUCTURE; + ends = ST_END_STRUCTURE; + } + else + { + gcc_assert (block == ST_MAP); + comp = COMP_MAP; + ends = ST_END_MAP; + } + + accept_statement(block); + push_state (&s, comp, gfc_new_block); + + gfc_new_block->component_access = ACCESS_PUBLIC; + compiling_type = 1; + + while (compiling_type) + { + st = next_statement (); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + /* Nested structure declarations will be captured as ST_DATA_DECL. */ + case ST_STRUCTURE_DECL: + /* Let a more specific error make it to decode_statement(). */ + if (gfc_error_check () == 0) + gfc_error ("Syntax error in nested structure declaration at %C"); + reject_statement (); + /* Skip the rest of this statement. */ + gfc_error_recovery (); + break; + + case ST_UNION: + accept_statement (ST_UNION); + parse_union (); + break; + + case ST_DATA_DECL: + /* The data declaration was a nested/ad-hoc STRUCTURE field. */ + accept_statement (ST_DATA_DECL); + if (gfc_new_block && gfc_new_block != gfc_current_block () + && gfc_new_block->attr.flavor == FL_STRUCT) + parse_struct_map (ST_STRUCTURE_DECL); + break; + + case ST_END_STRUCTURE: + case ST_END_MAP: + if (st == ends) + { + accept_statement (st); + compiling_type = 0; + } + else + unexpected_statement (st); + break; + + default: + unexpected_statement (st); + break; + } + } + + /* Validate each component. */ + sym = gfc_current_block (); + for (c = sym->components; c; c = c->next) + check_component (sym, c, &lock_comp, &event_comp); + + sym->attr.zero_comp = (sym->components == NULL); + + /* Allow parse_union to find this structure to add to its list of maps. */ + if (block == ST_MAP) + gfc_new_block = gfc_current_block (); + + pop_state (); +} + + /* Parse a derived type. */ static void @@ -2762,170 +3137,7 @@ endType: */ sym = gfc_current_block (); for (c = sym->components; c; c = c->next) - { - bool coarray, lock_type, event_type, allocatable, pointer; - coarray = lock_type = event_type = allocatable = pointer = false; - - /* Look for allocatable components. */ - if (c->attr.allocatable - || (c->ts.type == BT_CLASS && c->attr.class_ok - && CLASS_DATA (c)->attr.allocatable) - || (c->ts.type == BT_DERIVED && !c->attr.pointer - && c->ts.u.derived->attr.alloc_comp)) - { - allocatable = true; - sym->attr.alloc_comp = 1; - } - - /* Look for pointer components. */ - if (c->attr.pointer - || (c->ts.type == BT_CLASS && c->attr.class_ok - && CLASS_DATA (c)->attr.class_pointer) - || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp)) - { - pointer = true; - sym->attr.pointer_comp = 1; - } - - /* Look for procedure pointer components. */ - if (c->attr.proc_pointer - || (c->ts.type == BT_DERIVED - && c->ts.u.derived->attr.proc_pointer_comp)) - sym->attr.proc_pointer_comp = 1; - - /* Looking for coarray components. */ - if (c->attr.codimension - || (c->ts.type == BT_CLASS && c->attr.class_ok - && CLASS_DATA (c)->attr.codimension)) - { - coarray = true; - sym->attr.coarray_comp = 1; - } - - if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp - && !c->attr.pointer) - { - coarray = true; - sym->attr.coarray_comp = 1; - } - - /* Looking for lock_type components. */ - if ((c->ts.type == BT_DERIVED - && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) - || (c->ts.type == BT_CLASS && c->attr.class_ok - && CLASS_DATA (c)->ts.u.derived->from_intmod - == INTMOD_ISO_FORTRAN_ENV - && CLASS_DATA (c)->ts.u.derived->intmod_sym_id - == ISOFORTRAN_LOCK_TYPE) - || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp - && !allocatable && !pointer)) - { - lock_type = 1; - lock_comp = c; - sym->attr.lock_comp = 1; - } - - /* Looking for event_type components. */ - if ((c->ts.type == BT_DERIVED - && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) - || (c->ts.type == BT_CLASS && c->attr.class_ok - && CLASS_DATA (c)->ts.u.derived->from_intmod - == INTMOD_ISO_FORTRAN_ENV - && CLASS_DATA (c)->ts.u.derived->intmod_sym_id - == ISOFORTRAN_EVENT_TYPE) - || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp - && !allocatable && !pointer)) - { - event_type = 1; - event_comp = c; - sym->attr.event_comp = 1; - } - - /* Check for F2008, C1302 - and recall that pointers may not be coarrays - (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7), - unless there are nondirect [allocatable or pointer] components - involved (cf. 1.3.33.1 and 1.3.33.3). */ - - if (pointer && !coarray && lock_type) - gfc_error ("Component %s at %L of type LOCK_TYPE must have a " - "codimension or be a subcomponent of a coarray, " - "which is not possible as the component has the " - "pointer attribute", c->name, &c->loc); - else if (pointer && !coarray && c->ts.type == BT_DERIVED - && c->ts.u.derived->attr.lock_comp) - gfc_error ("Pointer component %s at %L has a noncoarray subcomponent " - "of type LOCK_TYPE, which must have a codimension or be a " - "subcomponent of a coarray", c->name, &c->loc); - - if (lock_type && allocatable && !coarray) - gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have " - "a codimension", c->name, &c->loc); - else if (lock_type && allocatable && c->ts.type == BT_DERIVED - && c->ts.u.derived->attr.lock_comp) - gfc_error ("Allocatable component %s at %L must have a codimension as " - "it has a noncoarray subcomponent of type LOCK_TYPE", - c->name, &c->loc); - - if (sym->attr.coarray_comp && !coarray && lock_type) - gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with " - "subcomponent of type LOCK_TYPE must have a codimension or " - "be a subcomponent of a coarray. (Variables of type %s may " - "not have a codimension as already a coarray " - "subcomponent exists)", c->name, &c->loc, sym->name); - - if (sym->attr.lock_comp && coarray && !lock_type) - gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with " - "subcomponent of type LOCK_TYPE must have a codimension or " - "be a subcomponent of a coarray. (Variables of type %s may " - "not have a codimension as %s at %L has a codimension or a " - "coarray subcomponent)", lock_comp->name, &lock_comp->loc, - sym->name, c->name, &c->loc); - - /* Similarly for EVENT TYPE. */ - - if (pointer && !coarray && event_type) - gfc_error ("Component %s at %L of type EVENT_TYPE must have a " - "codimension or be a subcomponent of a coarray, " - "which is not possible as the component has the " - "pointer attribute", c->name, &c->loc); - else if (pointer && !coarray && c->ts.type == BT_DERIVED - && c->ts.u.derived->attr.event_comp) - gfc_error ("Pointer component %s at %L has a noncoarray subcomponent " - "of type EVENT_TYPE, which must have a codimension or be a " - "subcomponent of a coarray", c->name, &c->loc); - - if (event_type && allocatable && !coarray) - gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have " - "a codimension", c->name, &c->loc); - else if (event_type && allocatable && c->ts.type == BT_DERIVED - && c->ts.u.derived->attr.event_comp) - gfc_error ("Allocatable component %s at %L must have a codimension as " - "it has a noncoarray subcomponent of type EVENT_TYPE", - c->name, &c->loc); - - if (sym->attr.coarray_comp && !coarray && event_type) - gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with " - "subcomponent of type EVENT_TYPE must have a codimension or " - "be a subcomponent of a coarray. (Variables of type %s may " - "not have a codimension as already a coarray " - "subcomponent exists)", c->name, &c->loc, sym->name); - - if (sym->attr.event_comp && coarray && !event_type) - gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with " - "subcomponent of type EVENT_TYPE must have a codimension or " - "be a subcomponent of a coarray. (Variables of type %s may " - "not have a codimension as %s at %L has a codimension or a " - "coarray subcomponent)", event_comp->name, &event_comp->loc, - sym->name, c->name, &c->loc); - - /* Look for private components. */ - if (sym->component_access == ACCESS_PRIVATE - || c->attr.access == ACCESS_PRIVATE - || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp)) - sym->attr.private_comp = 1; - } + check_component (sym, c, &lock_comp, &event_comp); if (!seen_component) sym->attr.zero_comp = 1; @@ -3348,6 +3560,7 @@ loop: case ST_PARAMETER: case ST_PUBLIC: case ST_PRIVATE: + case ST_STRUCTURE_DECL: case ST_DERIVED_DECL: case_decl: declSt: @@ -3364,6 +3577,10 @@ declSt: parse_interface (); break; + case ST_STRUCTURE_DECL: + parse_struct_map (ST_STRUCTURE_DECL); + break; + case ST_DERIVED_DECL: parse_derived (); break; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index f12fd5e5d2b..e8f71cf3035 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -28,6 +28,7 @@ enum gfc_compile_state COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBMODULE, COMP_SUBROUTINE, COMP_FUNCTION, COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS, COMP_BLOCK, COMP_ASSOCIATE, COMP_IF, + COMP_STRUCTURE, COMP_UNION, COMP_MAP, COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM, COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, COMP_DO_CONCURRENT }; @@ -58,6 +59,8 @@ extern gfc_state_data *gfc_state_stack; #define gfc_current_block() (gfc_state_stack->sym) #define gfc_current_state() (gfc_state_stack->state) +#define gfc_comp_struct(s) \ + ((s) == COMP_DERIVED || (s) == COMP_STRUCTURE || (s) == COMP_MAP) int gfc_check_do_variable (gfc_symtree *); bool gfc_find_state (gfc_compile_state); diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index d25d3de66b0..c2faa0f3e10 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1883,11 +1883,12 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, bool ppc_arg) { char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_ref *substring, *tail; + gfc_ref *substring, *tail, *tmp; gfc_component *component; gfc_symbol *sym = primary->symtree->n.sym; match m; bool unknown; + char sep; tail = NULL; @@ -1972,25 +1973,31 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (equiv_flag) return MATCH_YES; - if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%' + /* With DEC extensions, member separator may be '.' or '%'. */ + sep = gfc_peek_ascii_char (); + m = gfc_match_member_sep (sym); + if (m == MATCH_ERROR) + return MATCH_ERROR; + + if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED) gfc_set_default_type (sym, 0, sym->ns); - if (sym->ts.type == BT_UNKNOWN && gfc_match_char ('%') == MATCH_YES) + if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES) { gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name); return MATCH_ERROR; } else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS) - && gfc_match_char ('%') == MATCH_YES) + && m == MATCH_YES) { - gfc_error ("Unexpected %<%%%> for nonderived-type variable %qs at %C", - sym->name); + gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C", + sep, sym->name); return MATCH_ERROR; } if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS) - || gfc_match_char ('%') != MATCH_YES) + || m != MATCH_YES) goto check_substring; sym = sym->ts.u.derived; @@ -2061,15 +2068,24 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, break; } - component = gfc_find_component (sym, name, false, false); + component = gfc_find_component (sym, name, false, false, &tmp); if (component == NULL) return MATCH_ERROR; - tail = extend_ref (primary, tail); - tail->type = REF_COMPONENT; + /* Extend the reference chain determined by gfc_find_component. */ + if (primary->ref == NULL) + primary->ref = tmp; + else + { + /* Set by the for loop below for the last component ref. */ + gcc_assert (tail != NULL); + tail->next = tmp; + } - tail->u.c.component = component; - tail->u.c.sym = sym; + /* The reference chain may be longer than one hop for union + subcomponents; find the new tail. */ + for (tail = tmp; tail->next; tail = tail->next) + ; primary->ts = component->ts; @@ -2119,7 +2135,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, } if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS) - || gfc_match_char ('%') != MATCH_YES) + || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES) break; sym = component->ts.u.derived; @@ -2127,7 +2143,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, check_substring: unknown = false; - if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED) + if (primary->ts.type == BT_UNKNOWN && !gfc_fl_struct (sym->attr.flavor)) { if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER) { @@ -2548,11 +2564,11 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c /* Find the current component in the structure definition and check its access is not private. */ if (comp) - this_comp = gfc_find_component (sym, comp->name, false, false); + this_comp = gfc_find_component (sym, comp->name, false, false, NULL); else { this_comp = gfc_find_component (sym, (const char *)comp_tail->name, - false, false); + false, false, NULL); comp = NULL; /* Reset needed! */ } @@ -2596,7 +2612,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c if (comp && comp == sym->components && sym->attr.extension && comp_tail->val - && (comp_tail->val->ts.type != BT_DERIVED + && (!gfc_bt_struct (comp_tail->val->ts.type) || comp_tail->val->ts.u.derived != this_comp->ts.u.derived)) { @@ -2697,7 +2713,7 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result) e->symtree = symtree; e->expr_type = EXPR_FUNCTION; - gcc_assert (sym->attr.flavor == FL_DERIVED + gcc_assert (gfc_fl_struct (sym->attr.flavor) && symtree->n.sym->attr.flavor == FL_PROCEDURE); e->value.function.esym = sym; e->symtree->n.sym->attr.generic = 1; @@ -2795,15 +2811,29 @@ gfc_match_rvalue (gfc_expr **result) if (m != MATCH_YES) return m; - if (gfc_find_state (COMP_INTERFACE) - && !gfc_current_ns->has_import_set) - i = gfc_get_sym_tree (name, NULL, &symtree, false); - else - i = gfc_get_ha_sym_tree (name, &symtree); - - if (i) + /* Check if the symbol exists. */ + if (gfc_find_sym_tree (name, NULL, 1, &symtree)) return MATCH_ERROR; + /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT + type. For derived types we create a generic symbol which links to the + derived type symbol; STRUCTUREs are simpler and must not conflict with + variables. */ + if (!symtree) + if (gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree)) + return MATCH_ERROR; + if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT) + { + if (gfc_find_state (COMP_INTERFACE) + && !gfc_current_ns->has_import_set) + i = gfc_get_sym_tree (name, NULL, &symtree, false); + else + i = gfc_get_ha_sym_tree (name, &symtree); + if (i) + return MATCH_ERROR; + } + + sym = symtree->n.sym; e = NULL; where = gfc_current_locus; @@ -2914,6 +2944,7 @@ gfc_match_rvalue (gfc_expr **result) break; + case FL_STRUCT: case FL_DERIVED: sym = gfc_use_derived (sym); if (sym == NULL) @@ -3054,10 +3085,12 @@ gfc_match_rvalue (gfc_expr **result) via an IMPLICIT statement. This can't wait for the resolution phase. */ - if (gfc_peek_ascii_char () == '%' + old_loc = gfc_current_locus; + if (gfc_match_member_sep (sym) == MATCH_YES && sym->ts.type == BT_UNKNOWN && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED) gfc_set_default_type (sym, 0, sym->ns); + gfc_current_locus = old_loc; /* If the symbol has a (co)dimension attribute, the expression is a variable. */ @@ -3210,13 +3243,19 @@ gfc_match_rvalue (gfc_expr **result) break; generic_function: - gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */ + /* Look for symbol first; if not found, look for STRUCTURE type symbol + specially. Creates a generic symbol for derived types. */ + gfc_find_sym_tree (name, NULL, 1, &symtree); + if (!symtree) + gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree); + if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT) + gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */ e = gfc_get_expr (); e->symtree = symtree; e->expr_type = EXPR_FUNCTION; - if (sym->attr.flavor == FL_DERIVED) + if (gfc_fl_struct (sym->attr.flavor)) { e->value.function.esym = sym; e->symtree->n.sym->attr.generic = 1; @@ -3260,10 +3299,10 @@ gfc_match_rvalue (gfc_expr **result) static match match_variable (gfc_expr **result, int equiv_flag, int host_flag) { - gfc_symbol *sym; + gfc_symbol *sym, *dt_sym; gfc_symtree *st; gfc_expr *expr; - locus where; + locus where, old_loc; match m; /* Since nothing has any business being an lvalue in a module @@ -3294,6 +3333,17 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag) sym->attr.implied_index = 0; gfc_set_sym_referenced (sym); + + /* STRUCTUREs may share names with variables, but derived types may not. */ + if (sym->attr.flavor == FL_PROCEDURE && sym->generic + && (dt_sym = gfc_find_dt_in_generic (sym))) + { + if (dt_sym->attr.flavor == FL_DERIVED) + gfc_error ("Derived type '%s' cannot be used as a variable at %C", + sym->name); + return MATCH_ERROR; + } + switch (sym->attr.flavor) { case FL_VARIABLE: @@ -3379,11 +3429,13 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag) implicit_ns = gfc_current_ns; else implicit_ns = sym->ns; - - if (gfc_peek_ascii_char () == '%' + + old_loc = gfc_current_locus; + if (gfc_match_member_sep (sym) == MATCH_YES && sym->ts.type == BT_UNKNOWN && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED) gfc_set_default_type (sym, 0, implicit_ns); + gfc_current_locus = old_loc; } expr = gfc_get_expr (); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f5cd588308a..2c68af2b7e8 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -535,7 +535,7 @@ static void find_arglists (gfc_symbol *sym) { if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns - || sym->attr.flavor == FL_DERIVED || sym->attr.intrinsic) + || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic) return; resolve_formal_arglist (sym); @@ -1116,6 +1116,7 @@ resolve_contained_functions (gfc_namespace *ns) static bool resolve_fl_derived0 (gfc_symbol *sym); +static bool resolve_fl_struct (gfc_symbol *sym); /* Resolve all of the elements of a structure constructor and make sure that @@ -1132,8 +1133,13 @@ resolve_structure_cons (gfc_expr *expr, int init) t = true; - if (expr->ts.type == BT_DERIVED) - resolve_fl_derived0 (expr->ts.u.derived); + if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION) + { + if (expr->ts.u.derived->attr.flavor == FL_DERIVED) + resolve_fl_derived0 (expr->ts.u.derived); + else + resolve_fl_struct (expr->ts.u.derived); + } cons = gfc_constructor_first (expr->value.constructor); @@ -1561,7 +1567,7 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) gfc_namespace* real_context; if (sym->attr.flavor == FL_PROGRAM - || sym->attr.flavor == FL_DERIVED) + || gfc_fl_struct (sym->attr.flavor)) return false; gcc_assert (sym->attr.flavor == FL_PROCEDURE); @@ -2548,7 +2554,7 @@ resolve_generic_f (gfc_expr *expr) generic: if (!intr) for (intr = sym->generic; intr; intr = intr->next) - if (intr->sym->attr.flavor == FL_DERIVED) + if (gfc_fl_struct (intr->sym->attr.flavor)) break; if (sym->ns->parent == NULL) @@ -5715,7 +5721,7 @@ get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, continue; if ((ref->u.c.component->ts.type == BT_CLASS - || (check_types && ref->u.c.component->ts.type == BT_DERIVED)) + || (check_types && gfc_bt_struct (ref->u.c.component->ts.type))) && ref->u.c.component->attr.flavor != FL_PROCEDURE) { declared = ref->u.c.component->ts.u.derived; @@ -5978,7 +5984,7 @@ resolve_typebound_function (gfc_expr* e) is present. */ ts = expr->ts; declared = ts.u.derived; - c = gfc_find_component (declared, "_vptr", true, true); + c = gfc_find_component (declared, "_vptr", true, true, NULL); if (c->ts.u.derived == NULL) c->ts.u.derived = gfc_find_derived_vtab (declared); @@ -6025,14 +6031,14 @@ resolve_typebound_function (gfc_expr* e) return false; /* Weed out cases of the ultimate component being a derived type. */ - if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) + if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type)) || (!class_ref && st->n.sym->ts.type != BT_CLASS)) { gfc_free_ref_list (new_ref); return resolve_compcall (e, NULL); } - c = gfc_find_component (declared, "_data", true, true); + c = gfc_find_component (declared, "_data", true, true, NULL); declared = c->ts.u.derived; /* Treat the call as if it is a typebound procedure, in order to roll @@ -6111,7 +6117,7 @@ resolve_typebound_subroutine (gfc_code *code) that any delays in resolution are corrected and that the vtab is present. */ declared = expr->ts.u.derived; - c = gfc_find_component (declared, "_vptr", true, true); + c = gfc_find_component (declared, "_vptr", true, true, NULL); if (c->ts.u.derived == NULL) c->ts.u.derived = gfc_find_derived_vtab (declared); @@ -6156,7 +6162,7 @@ resolve_typebound_subroutine (gfc_code *code) get_declared_from_expr (&class_ref, &new_ref, code->expr1, true); /* Weed out cases of the ultimate component being a derived type. */ - if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) + if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type)) || (!class_ref && st->n.sym->ts.type != BT_CLASS)) { gfc_free_ref_list (new_ref); @@ -7140,7 +7146,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) gfc_typespec ts; gfc_expr *init_e; - if (code->ext.alloc.ts.type == BT_DERIVED) + if (gfc_bt_struct (code->ext.alloc.ts.type)) ts = code->ext.alloc.ts; else ts = e->ts; @@ -7148,7 +7154,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) if (ts.type == BT_CLASS) ts = ts.u.derived->components->ts; - if (ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&ts))) + if (gfc_bt_struct (ts.type) && (init_e = gfc_default_initializer (&ts))) { gfc_code *init_st = gfc_get_code (EXEC_INIT_ASSIGN); init_st->loc = code->loc; @@ -7282,7 +7288,7 @@ check_symbols: sym = a->expr->symtree->n.sym; /* TODO - check derived type components. */ - if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) + if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS) continue; if ((ar->start[i] != NULL @@ -8220,7 +8226,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) if (!gfc_build_class_symbol (&sym->ts, &attr, &as)) gcc_unreachable (); /* Make sure the _vptr is set. */ - c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true); + c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true, NULL); if (c->ts.u.derived == NULL) c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived); CLASS_DATA (sym)->attr.pointer = 1; @@ -9911,7 +9917,7 @@ nonscalar_typebound_assign (gfc_symbol *derived, int depth) for (c= derived->components; c; c = c->next) { - if ((c->ts.type != BT_DERIVED + if ((!gfc_bt_struct (c->ts.type) || c->attr.pointer || c->attr.allocatable || c->attr.proc_pointer_comp @@ -10051,7 +10057,7 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) /* The intrinsic assignment does the right thing for pointers of all kinds and allocatable components. */ - if (comp1->ts.type != BT_DERIVED + if (!gfc_bt_struct (comp1->ts.type) || comp1->attr.pointer || comp1->attr.allocatable || comp1->attr.proc_pointer_comp @@ -11433,7 +11439,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s); if (s && s->attr.generic) s = gfc_find_dt_in_generic (s); - if (s && s->attr.flavor != FL_DERIVED) + if (s && !gfc_fl_struct (s->attr.flavor)) { gfc_error ("The type %qs cannot be host associated at %L " "because it is blocked by an incompatible object " @@ -12733,7 +12739,8 @@ resolve_typebound_procedure (gfc_symtree* stree) } /* Try to find a name collision with an inherited component. */ - if (super_type && gfc_find_component (super_type, stree->name, true, true)) + if (super_type && gfc_find_component (super_type, stree->name, true, true, + NULL)) { gfc_error ("Procedure %qs at %L has the same name as an inherited" " component of %qs", @@ -12881,7 +12888,7 @@ check_defined_assignments (gfc_symbol *derived) for (c = derived->components; c; c = c->next) { - if (c->ts.type != BT_DERIVED + if (!gfc_bt_struct (c->ts.type) || c->attr.pointer || c->attr.allocatable || c->attr.proc_pointer_comp @@ -12907,435 +12914,498 @@ check_defined_assignments (gfc_symbol *derived) } -/* Resolve the components of a derived type. This does not have to wait until - resolution stage, but can be done as soon as the dt declaration has been - parsed. */ +/* Resolve a single component of a derived type or structure. */ static bool -resolve_fl_derived0 (gfc_symbol *sym) +resolve_component (gfc_component *c, gfc_symbol *sym) { - gfc_symbol* super_type; - gfc_component *c; + gfc_symbol *super_type; - if (sym->attr.unlimited_polymorphic) + if (c->attr.artificial) return true; - super_type = gfc_get_derived_super_type (sym); + /* F2008, C442. */ + if ((!sym->attr.is_class || c != sym->components) + && c->attr.codimension + && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED))) + { + gfc_error ("Coarray component %qs at %L must be allocatable with " + "deferred shape", c->name, &c->loc); + return false; + } - /* F2008, C432. */ - if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp) + /* F2008, C443. */ + if (c->attr.codimension && c->ts.type == BT_DERIVED + && c->ts.u.derived->ts.is_iso_c) { - gfc_error ("As extending type %qs at %L has a coarray component, " - "parent type %qs shall also have one", sym->name, - &sym->declared_at, super_type->name); + gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " + "shall not be a coarray", c->name, &c->loc); return false; } - /* Ensure the extended type gets resolved before we do. */ - if (super_type && !resolve_fl_derived0 (super_type)) - return false; + /* F2008, C444. */ + if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp + && (c->attr.codimension || c->attr.pointer || c->attr.dimension + || c->attr.allocatable)) + { + gfc_error ("Component %qs at %L with coarray component " + "shall be a nonpointer, nonallocatable scalar", + c->name, &c->loc); + return false; + } - /* An ABSTRACT type must be extensible. */ - if (sym->attr.abstract && !gfc_type_is_extensible (sym)) + /* F2008, C448. */ + if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer)) { - gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT", - sym->name, &sym->declared_at); + gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but " + "is not an array pointer", c->name, &c->loc); return false; } - c = (sym->attr.is_class) ? sym->components->ts.u.derived->components - : sym->components; + if (c->attr.proc_pointer && c->ts.interface) + { + gfc_symbol *ifc = c->ts.interface; - bool success = true; + if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc)) + { + c->tb->error = 1; + return false; + } - for ( ; c != NULL; c = c->next) + if (ifc->attr.if_source || ifc->attr.intrinsic) + { + /* Resolve interface and copy attributes. */ + if (ifc->formal && !ifc->formal_ns) + resolve_symbol (ifc); + if (ifc->attr.intrinsic) + gfc_resolve_intrinsic (ifc, &ifc->declared_at); + + if (ifc->result) + { + c->ts = ifc->result->ts; + c->attr.allocatable = ifc->result->attr.allocatable; + c->attr.pointer = ifc->result->attr.pointer; + c->attr.dimension = ifc->result->attr.dimension; + c->as = gfc_copy_array_spec (ifc->result->as); + c->attr.class_ok = ifc->result->attr.class_ok; + } + else + { + c->ts = ifc->ts; + c->attr.allocatable = ifc->attr.allocatable; + c->attr.pointer = ifc->attr.pointer; + c->attr.dimension = ifc->attr.dimension; + c->as = gfc_copy_array_spec (ifc->as); + c->attr.class_ok = ifc->attr.class_ok; + } + c->ts.interface = ifc; + c->attr.function = ifc->attr.function; + c->attr.subroutine = ifc->attr.subroutine; + + c->attr.pure = ifc->attr.pure; + c->attr.elemental = ifc->attr.elemental; + c->attr.recursive = ifc->attr.recursive; + c->attr.always_explicit = ifc->attr.always_explicit; + c->attr.ext_attr |= ifc->attr.ext_attr; + /* Copy char length. */ + if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) + { + gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); + if (cl->length && !cl->resolved + && !gfc_resolve_expr (cl->length)) + { + c->tb->error = 1; + return false; + } + c->ts.u.cl = cl; + } + } + } + else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN) { - if (c->attr.artificial) - continue; + /* Since PPCs are not implicitly typed, a PPC without an explicit + interface must be a subroutine. */ + gfc_add_subroutine (&c->attr, c->name, &c->loc); + } - /* F2008, C442. */ - if ((!sym->attr.is_class || c != sym->components) - && c->attr.codimension - && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED))) - { - gfc_error ("Coarray component %qs at %L must be allocatable with " - "deferred shape", c->name, &c->loc); - success = false; - continue; - } + /* Procedure pointer components: Check PASS arg. */ + if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0 + && !sym->attr.vtype) + { + gfc_symbol* me_arg; - /* F2008, C443. */ - if (c->attr.codimension && c->ts.type == BT_DERIVED - && c->ts.u.derived->ts.is_iso_c) - { - gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " - "shall not be a coarray", c->name, &c->loc); - success = false; - continue; - } + if (c->tb->pass_arg) + { + gfc_formal_arglist* i; - /* F2008, C444. */ - if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp - && (c->attr.codimension || c->attr.pointer || c->attr.dimension - || c->attr.allocatable)) - { - gfc_error ("Component %qs at %L with coarray component " - "shall be a nonpointer, nonallocatable scalar", - c->name, &c->loc); - success = false; - continue; - } + /* If an explicit passing argument name is given, walk the arg-list + and look for it. */ - /* F2008, C448. */ - if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer)) - { - gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but " - "is not an array pointer", c->name, &c->loc); - success = false; - continue; - } + me_arg = NULL; + c->tb->pass_arg_num = 1; + for (i = c->ts.interface->formal; i; i = i->next) + { + if (!strcmp (i->sym->name, c->tb->pass_arg)) + { + me_arg = i->sym; + break; + } + c->tb->pass_arg_num++; + } - if (c->attr.proc_pointer && c->ts.interface) - { - gfc_symbol *ifc = c->ts.interface; + if (!me_arg) + { + gfc_error ("Procedure pointer component %qs with PASS(%s) " + "at %L has no argument %qs", c->name, + c->tb->pass_arg, &c->loc, c->tb->pass_arg); + c->tb->error = 1; + return false; + } + } + else + { + /* Otherwise, take the first one; there should in fact be at least + one. */ + c->tb->pass_arg_num = 1; + if (!c->ts.interface->formal) + { + gfc_error ("Procedure pointer component %qs with PASS at %L " + "must have at least one argument", + c->name, &c->loc); + c->tb->error = 1; + return false; + } + me_arg = c->ts.interface->formal->sym; + } - if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc)) - { - c->tb->error = 1; - success = false; - continue; - } + /* Now check that the argument-type matches. */ + gcc_assert (me_arg); + 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 + && CLASS_DATA (me_arg)->ts.u.derived != sym)) + { + gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" + " the derived type %qs", me_arg->name, c->name, + me_arg->name, &c->loc, sym->name); + c->tb->error = 1; + return false; + } - if (ifc->attr.if_source || ifc->attr.intrinsic) - { - /* Resolve interface and copy attributes. */ - if (ifc->formal && !ifc->formal_ns) - resolve_symbol (ifc); - if (ifc->attr.intrinsic) - gfc_resolve_intrinsic (ifc, &ifc->declared_at); + /* Check for C453. */ + if (me_arg->attr.dimension) + { + gfc_error ("Argument %qs of %qs with PASS(%s) at %L " + "must be scalar", me_arg->name, c->name, me_arg->name, + &c->loc); + c->tb->error = 1; + return false; + } - if (ifc->result) - { - c->ts = ifc->result->ts; - c->attr.allocatable = ifc->result->attr.allocatable; - c->attr.pointer = ifc->result->attr.pointer; - c->attr.dimension = ifc->result->attr.dimension; - c->as = gfc_copy_array_spec (ifc->result->as); - c->attr.class_ok = ifc->result->attr.class_ok; - } - else - { - c->ts = ifc->ts; - c->attr.allocatable = ifc->attr.allocatable; - c->attr.pointer = ifc->attr.pointer; - c->attr.dimension = ifc->attr.dimension; - c->as = gfc_copy_array_spec (ifc->as); - c->attr.class_ok = ifc->attr.class_ok; - } - c->ts.interface = ifc; - c->attr.function = ifc->attr.function; - c->attr.subroutine = ifc->attr.subroutine; - - c->attr.pure = ifc->attr.pure; - c->attr.elemental = ifc->attr.elemental; - c->attr.recursive = ifc->attr.recursive; - c->attr.always_explicit = ifc->attr.always_explicit; - c->attr.ext_attr |= ifc->attr.ext_attr; - /* Copy char length. */ - if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) - { - gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); - if (cl->length && !cl->resolved - && !gfc_resolve_expr (cl->length)) - { - c->tb->error = 1; - success = false; - continue; - } - c->ts.u.cl = cl; - } - } - } - else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN) - { - /* Since PPCs are not implicitly typed, a PPC without an explicit - interface must be a subroutine. */ - gfc_add_subroutine (&c->attr, c->name, &c->loc); - } + if (me_arg->attr.pointer) + { + gfc_error ("Argument %qs of %qs with PASS(%s) at %L " + "may not have the POINTER attribute", me_arg->name, + c->name, me_arg->name, &c->loc); + c->tb->error = 1; + return false; + } - /* Procedure pointer components: Check PASS arg. */ - if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0 - && !sym->attr.vtype) - { - gfc_symbol* me_arg; + if (me_arg->attr.allocatable) + { + gfc_error ("Argument %qs of %qs with PASS(%s) at %L " + "may not be ALLOCATABLE", me_arg->name, c->name, + me_arg->name, &c->loc); + c->tb->error = 1; + return false; + } - if (c->tb->pass_arg) - { - gfc_formal_arglist* i; + if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS) + { + gfc_error ("Non-polymorphic passed-object dummy argument of %qs" + " at %L", c->name, &c->loc); + return false; + } - /* If an explicit passing argument name is given, walk the arg-list - and look for it. */ + } - me_arg = NULL; - c->tb->pass_arg_num = 1; - for (i = c->ts.interface->formal; i; i = i->next) - { - if (!strcmp (i->sym->name, c->tb->pass_arg)) - { - me_arg = i->sym; - break; - } - c->tb->pass_arg_num++; - } + /* Check type-spec if this is not the parent-type component. */ + if (((sym->attr.is_class + && (!sym->components->ts.u.derived->attr.extension + || c != sym->components->ts.u.derived->components)) + || (!sym->attr.is_class + && (!sym->attr.extension || c != sym->components))) + && !sym->attr.vtype + && !resolve_typespec_used (&c->ts, &c->loc, c->name)) + return false; - if (!me_arg) - { - gfc_error ("Procedure pointer component %qs with PASS(%s) " - "at %L has no argument %qs", c->name, - c->tb->pass_arg, &c->loc, c->tb->pass_arg); - c->tb->error = 1; - success = false; - continue; - } - } - else - { - /* Otherwise, take the first one; there should in fact be at least - one. */ - c->tb->pass_arg_num = 1; - if (!c->ts.interface->formal) - { - gfc_error ("Procedure pointer component %qs with PASS at %L " - "must have at least one argument", - c->name, &c->loc); - c->tb->error = 1; - success = false; - continue; - } - me_arg = c->ts.interface->formal->sym; - } + super_type = gfc_get_derived_super_type (sym); - /* Now check that the argument-type matches. */ - gcc_assert (me_arg); - 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 - && CLASS_DATA (me_arg)->ts.u.derived != sym)) - { - gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" - " the derived type %qs", me_arg->name, c->name, - me_arg->name, &c->loc, sym->name); - c->tb->error = 1; - success = false; - continue; - } + /* If this type is an extension, set the accessibility of the parent + component. */ + if (super_type + && ((sym->attr.is_class + && c == sym->components->ts.u.derived->components) + || (!sym->attr.is_class && c == sym->components)) + && strcmp (super_type->name, c->name) == 0) + c->attr.access = super_type->attr.access; + + /* If this type is an extension, see if this component has the same name + as an inherited type-bound procedure. */ + if (super_type && !sym->attr.is_class + && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) + { + gfc_error ("Component %qs of %qs at %L has the same name as an" + " inherited type-bound procedure", + c->name, sym->name, &c->loc); + return false; + } - /* Check for C453. */ - if (me_arg->attr.dimension) - { - gfc_error ("Argument %qs of %qs with PASS(%s) at %L " - "must be scalar", me_arg->name, c->name, me_arg->name, - &c->loc); - c->tb->error = 1; - success = false; - continue; - } + if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer + && !c->ts.deferred) + { + if (c->ts.u.cl->length == NULL + || (!resolve_charlen(c->ts.u.cl)) + || !gfc_is_constant_expr (c->ts.u.cl->length)) + { + gfc_error ("Character length of component %qs needs to " + "be a constant specification expression at %L", + c->name, + c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); + return false; + } + } - if (me_arg->attr.pointer) - { - gfc_error ("Argument %qs of %qs with PASS(%s) at %L " - "may not have the POINTER attribute", me_arg->name, - c->name, me_arg->name, &c->loc); - c->tb->error = 1; - success = false; - continue; - } + if (c->ts.type == BT_CHARACTER && c->ts.deferred + && !c->attr.pointer && !c->attr.allocatable) + { + gfc_error ("Character component %qs of %qs at %L with deferred " + "length must be a POINTER or ALLOCATABLE", + c->name, sym->name, &c->loc); + return false; + } - if (me_arg->attr.allocatable) - { - gfc_error ("Argument %qs of %qs with PASS(%s) at %L " - "may not be ALLOCATABLE", me_arg->name, c->name, - me_arg->name, &c->loc); - c->tb->error = 1; - success = false; - continue; - } + /* Add the hidden deferred length field. */ + if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function + && !sym->attr.is_class) + { + char name[GFC_MAX_SYMBOL_LEN+9]; + gfc_component *strlen; + sprintf (name, "_%s_length", c->name); + strlen = gfc_find_component (sym, name, true, true, NULL); + if (strlen == NULL) + { + if (!gfc_add_component (sym, name, &strlen)) + return false; + strlen->ts.type = BT_INTEGER; + strlen->ts.kind = gfc_charlen_int_kind; + strlen->attr.access = ACCESS_PRIVATE; + strlen->attr.artificial = 1; + } + } - if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS) - { - gfc_error ("Non-polymorphic passed-object dummy argument of %qs" - " at %L", c->name, &c->loc); - success = false; - continue; - } + if (c->ts.type == BT_DERIVED + && sym->component_access != ACCESS_PRIVATE + && gfc_check_symbol_access (sym) + && !is_sym_host_assoc (c->ts.u.derived, sym->ns) + && !c->ts.u.derived->attr.use_assoc + && !gfc_check_symbol_access (c->ts.u.derived) + && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a " + "PRIVATE type and cannot be a component of " + "%qs, which is PUBLIC at %L", c->name, + sym->name, &sym->declared_at)) + return false; - } + if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS) + { + gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) " + "type %s", c->name, &c->loc, sym->name); + return false; + } - /* Check type-spec if this is not the parent-type component. */ - if (((sym->attr.is_class - && (!sym->components->ts.u.derived->attr.extension - || c != sym->components->ts.u.derived->components)) - || (!sym->attr.is_class - && (!sym->attr.extension || c != sym->components))) - && !sym->attr.vtype - && !resolve_typespec_used (&c->ts, &c->loc, c->name)) - return false; + if (sym->attr.sequence) + { + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0) + { + gfc_error ("Component %s of SEQUENCE type declared at %L does " + "not have the SEQUENCE attribute", + c->ts.u.derived->name, &sym->declared_at); + return false; + } + } - /* If this type is an extension, set the accessibility of the parent - component. */ - if (super_type - && ((sym->attr.is_class - && c == sym->components->ts.u.derived->components) - || (!sym->attr.is_class && c == sym->components)) - && strcmp (super_type->name, c->name) == 0) - c->attr.access = super_type->attr.access; - - /* If this type is an extension, see if this component has the same name - as an inherited type-bound procedure. */ - if (super_type && !sym->attr.is_class - && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) - { - gfc_error ("Component %qs of %qs at %L has the same name as an" - " inherited type-bound procedure", - c->name, sym->name, &c->loc); - return false; - } + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic) + c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived); + else if (c->ts.type == BT_CLASS && c->attr.class_ok + && CLASS_DATA (c)->ts.u.derived->attr.generic) + CLASS_DATA (c)->ts.u.derived + = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived); - if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer - && !c->ts.deferred) - { - if (c->ts.u.cl->length == NULL - || (!resolve_charlen(c->ts.u.cl)) - || !gfc_is_constant_expr (c->ts.u.cl->length)) - { - gfc_error ("Character length of component %qs needs to " - "be a constant specification expression at %L", - c->name, - c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); - return false; - } - } + if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype + && c->attr.pointer && c->ts.u.derived->components == NULL + && !c->ts.u.derived->attr.zero_comp) + { + gfc_error ("The pointer component %qs of %qs at %L is a type " + "that has not been declared", c->name, sym->name, + &c->loc); + return false; + } - if (c->ts.type == BT_CHARACTER && c->ts.deferred - && !c->attr.pointer && !c->attr.allocatable) - { - gfc_error ("Character component %qs of %qs at %L with deferred " - "length must be a POINTER or ALLOCATABLE", - c->name, sym->name, &c->loc); - return false; - } + if (c->ts.type == BT_CLASS && c->attr.class_ok + && CLASS_DATA (c)->attr.class_pointer + && CLASS_DATA (c)->ts.u.derived->components == NULL + && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp + && !UNLIMITED_POLY (c)) + { + gfc_error ("The pointer component %qs of %qs at %L is a type " + "that has not been declared", c->name, sym->name, + &c->loc); + return false; + } - /* Add the hidden deferred length field. */ - if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function - && !sym->attr.is_class) - { - char name[GFC_MAX_SYMBOL_LEN+9]; - gfc_component *strlen; - sprintf (name, "_%s_length", c->name); - strlen = gfc_find_component (sym, name, true, true); - if (strlen == NULL) - { - if (!gfc_add_component (sym, name, &strlen)) - return false; - strlen->ts.type = BT_INTEGER; - strlen->ts.kind = gfc_charlen_int_kind; - strlen->attr.access = ACCESS_PRIVATE; - strlen->attr.artificial = 1; - } - } + /* C437. */ + if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE + && (!c->attr.class_ok + || !(CLASS_DATA (c)->attr.class_pointer + || CLASS_DATA (c)->attr.allocatable))) + { + gfc_error ("Component %qs with CLASS at %L must be allocatable " + "or pointer", c->name, &c->loc); + /* Prevent a recurrence of the error. */ + c->ts.type = BT_UNKNOWN; + return false; + } - if (c->ts.type == BT_DERIVED - && sym->component_access != ACCESS_PRIVATE - && gfc_check_symbol_access (sym) - && !is_sym_host_assoc (c->ts.u.derived, sym->ns) - && !c->ts.u.derived->attr.use_assoc - && !gfc_check_symbol_access (c->ts.u.derived) - && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a " - "PRIVATE type and cannot be a component of " - "%qs, which is PUBLIC at %L", c->name, - sym->name, &sym->declared_at)) - return false; + /* Ensure that all the derived type components are put on the + derived type list; even in formal namespaces, where derived type + pointer components might not have been declared. */ + if (c->ts.type == BT_DERIVED + && c->ts.u.derived + && c->ts.u.derived->components + && c->attr.pointer + && sym != c->ts.u.derived) + add_dt_to_dt_list (c->ts.u.derived); - if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS) - { - gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) " - "type %s", c->name, &c->loc, sym->name); - return false; - } + if (!gfc_resolve_array_spec (c->as, + !(c->attr.pointer || c->attr.proc_pointer + || c->attr.allocatable))) + return false; - if (sym->attr.sequence) - { - if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0) - { - gfc_error ("Component %s of SEQUENCE type declared at %L does " - "not have the SEQUENCE attribute", - c->ts.u.derived->name, &sym->declared_at); - return false; - } - } + if (c->initializer && !sym->attr.vtype + && !gfc_check_assign_symbol (sym, c, c->initializer)) + return false; - if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic) - c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived); - else if (c->ts.type == BT_CLASS && c->attr.class_ok - && CLASS_DATA (c)->ts.u.derived->attr.generic) - CLASS_DATA (c)->ts.u.derived - = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived); + return true; +} - if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype - && c->attr.pointer && c->ts.u.derived->components == NULL - && !c->ts.u.derived->attr.zero_comp) - { - gfc_error ("The pointer component %qs of %qs at %L is a type " - "that has not been declared", c->name, sym->name, - &c->loc); - return false; - } - if (c->ts.type == BT_CLASS && c->attr.class_ok - && CLASS_DATA (c)->attr.class_pointer - && CLASS_DATA (c)->ts.u.derived->components == NULL - && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp - && !UNLIMITED_POLY (c)) - { - gfc_error ("The pointer component %qs of %qs at %L is a type " - "that has not been declared", c->name, sym->name, - &c->loc); - return false; - } +/* Be nice about the locus for a structure expression - show the locus of the + first non-null sub-expression if we can. */ - /* C437. */ - if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE - && (!c->attr.class_ok - || !(CLASS_DATA (c)->attr.class_pointer - || CLASS_DATA (c)->attr.allocatable))) - { - gfc_error ("Component %qs with CLASS at %L must be allocatable " - "or pointer", c->name, &c->loc); - /* Prevent a recurrence of the error. */ - c->ts.type = BT_UNKNOWN; - return false; - } +static locus * +cons_where (gfc_expr *struct_expr) +{ + gfc_constructor *cons; - /* Ensure that all the derived type components are put on the - derived type list; even in formal namespaces, where derived type - pointer components might not have been declared. */ - if (c->ts.type == BT_DERIVED - && c->ts.u.derived - && c->ts.u.derived->components - && c->attr.pointer - && sym != c->ts.u.derived) - add_dt_to_dt_list (c->ts.u.derived); + gcc_assert (struct_expr && struct_expr->expr_type == EXPR_STRUCTURE); - if (!gfc_resolve_array_spec (c->as, - !(c->attr.pointer || c->attr.proc_pointer - || c->attr.allocatable))) - return false; + cons = gfc_constructor_first (struct_expr->value.constructor); + for (; cons; cons = gfc_constructor_next (cons)) + { + if (cons->expr && cons->expr->expr_type != EXPR_NULL) + return &cons->expr->where; + } - if (c->initializer && !sym->attr.vtype - && !gfc_check_assign_symbol (sym, c, c->initializer)) - return false; + return &struct_expr->where; +} + +/* Resolve the components of a structure type. Much less work than derived + types. */ + +static bool +resolve_fl_struct (gfc_symbol *sym) +{ + gfc_component *c; + gfc_expr *init = NULL; + bool success; + + /* Make sure UNIONs do not have overlapping initializers. */ + if (sym->attr.flavor == FL_UNION) + { + for (c = sym->components; c; c = c->next) + { + if (init && c->initializer) + { + gfc_error ("Conflicting initializers in union at %L and %L", + cons_where (init), cons_where (c->initializer)); + gfc_free_expr (c->initializer); + c->initializer = NULL; + } + if (init == NULL) + init = c->initializer; + } } + success = true; + for (c = sym->components; c; c = c->next) + if (!resolve_component (c, sym)) + success = false; + + if (!success) + return false; + + if (sym->components) + add_dt_to_dt_list (sym); + + return true; +} + + +/* Resolve the components of a derived type. This does not have to wait until + resolution stage, but can be done as soon as the dt declaration has been + parsed. */ + +static bool +resolve_fl_derived0 (gfc_symbol *sym) +{ + gfc_symbol* super_type; + gfc_component *c; + bool success; + + if (sym->attr.unlimited_polymorphic) + return true; + + super_type = gfc_get_derived_super_type (sym); + + /* F2008, C432. */ + if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp) + { + gfc_error ("As extending type %qs at %L has a coarray component, " + "parent type %qs shall also have one", sym->name, + &sym->declared_at, super_type->name); + return false; + } + + /* Ensure the extended type gets resolved before we do. */ + if (super_type && !resolve_fl_derived0 (super_type)) + return false; + + /* An ABSTRACT type must be extensible. */ + if (sym->attr.abstract && !gfc_type_is_extensible (sym)) + { + gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT", + sym->name, &sym->declared_at); + return false; + } + + c = (sym->attr.is_class) ? sym->components->ts.u.derived->components + : sym->components; + + success = true; + for ( ; c != NULL; c = c->next) + if (!resolve_component (c, sym)) + success = false; + if (!success) return false; @@ -13396,8 +13466,8 @@ resolve_fl_derived (gfc_symbol *sym) if (sym->attr.is_class && sym->ts.u.derived == NULL) { /* Fix up incomplete CLASS symbols. */ - gfc_component *data = gfc_find_component (sym, "_data", true, true); - gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true); + gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL); + gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL); /* Nothing more to do for unlimited polymorphic entities. */ if (data->ts.u.derived->attr.unlimited_polymorphic) @@ -13616,6 +13686,11 @@ resolve_symbol (gfc_symbol *sym) return; sym->resolved = 1; + /* No symbol will ever have union type; only components can be unions. + Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION + (just like derived type declaration symbols have flavor FL_DERIVED). */ + gcc_assert (sym->ts.type != BT_UNION); + if (sym->attr.artificial) return; @@ -13687,6 +13762,10 @@ resolve_symbol (gfc_symbol *sym) if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym)) return; + else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION) + && !resolve_fl_struct (sym)) + return; + /* Symbols that are module procedures with results (functions) have the types and array specification copied for type checking in procedures that call them, as well as for saving to a module @@ -15030,7 +15109,7 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) for (; c ; c = c->next) { - if (c->ts.type == BT_DERIVED + if (gfc_bt_struct (c->ts.type) && (!resolve_equivalence_derived(c->ts.u.derived, sym, e))) return false; diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 8efd12ca68b..0ee7decffd4 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -40,6 +40,7 @@ const mstring flavors[] = minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER), minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE), minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST), + minit ("UNION", FL_UNION), minit ("STRUCTURE", FL_STRUCT), minit (NULL, -1) }; @@ -444,7 +445,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) case FL_BLOCK_DATA: case FL_MODULE: case FL_LABEL: - case FL_DERIVED: + case_fl_struct: case FL_PARAMETER: a1 = gfc_code2string (flavors, attr->flavor); a2 = save; @@ -740,7 +741,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) break; - case FL_DERIVED: + case_fl_struct: conf2 (dummy); conf2 (pointer); conf2 (target); @@ -1579,7 +1580,7 @@ gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name, { if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE - || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED + || f == FL_PARAMETER || f == FL_LABEL || gfc_fl_struct(f) || f == FL_NAMELIST) && check_used (attr, name, where)) return false; @@ -2048,6 +2049,11 @@ gfc_add_component (gfc_symbol *sym, const char *name, { gfc_component *p, *tail; + /* Check for existing components with the same name, but not for union + components or containers. Unions and maps are anonymous so they have + unique internal names which will never conflict. + Don't use gfc_find_component here because it calls gfc_use_derived, + but the derived type may not be fully defined yet. */ tail = NULL; for (p = sym->components; p; p = p->next) @@ -2063,7 +2069,8 @@ gfc_add_component (gfc_symbol *sym, const char *name, } if (sym->attr.extension - && gfc_find_component (sym->components->ts.u.derived, name, true, true)) + && gfc_find_component (sym->components->ts.u.derived, + name, true, true, NULL)) { gfc_error ("Component %qs at %C already in the parent type " "at %L", name, &sym->components->ts.u.derived->declared_at); @@ -2154,7 +2161,7 @@ gfc_use_derived (gfc_symbol *sym) return NULL; } - if (s == NULL || s->attr.flavor != FL_DERIVED) + if (s == NULL || !gfc_fl_struct (s->attr.flavor)) goto bad; /* Get rid of symbol sym, translating all references to s. */ @@ -2188,28 +2195,113 @@ bad: } +/* Find the component with the given name in the union type symbol. + If ref is not NULL it will be set to the chain of components through which + the component can actually be accessed. This is necessary for unions because + intermediate structures may be maps, nested structures, or other unions, + all of which may (or must) be 'anonymous' to user code. */ + +static gfc_component * +find_union_component (gfc_symbol *un, const char *name, + bool noaccess, gfc_ref **ref) +{ + gfc_component *m, *check; + gfc_ref *sref, *tmp; + + for (m = un->components; m; m = m->next) + { + check = gfc_find_component (m->ts.u.derived, name, noaccess, true, &tmp); + if (check == NULL) + continue; + + /* Found component somewhere in m; chain the refs together. */ + if (ref) + { + /* Map ref. */ + sref = gfc_get_ref (); + sref->type = REF_COMPONENT; + sref->u.c.component = m; + sref->u.c.sym = m->ts.u.derived; + sref->next = tmp; + + *ref = sref; + } + /* Other checks (such as access) were done in the recursive calls. */ + return check; + } + return NULL; +} + + /* Given a derived type node and a component name, try to locate the component structure. Returns the NULL pointer if the component is not found or the components are private. If noaccess is set, no access - checks are done. */ + checks are done. If silent is set, an error will not be generated if + the component cannot be found or accessed. + + If ref is not NULL, *ref is set to represent the chain of components + required to get to the ultimate component. + + If the component is simply a direct subcomponent, or is inherited from a + parent derived type in the given derived type, this is a single ref with its + component set to the returned component. + + Otherwise, *ref is constructed as a chain of subcomponents. This occurs + when the component is found through an implicit chain of nested union and + map components. Unions and maps are "anonymous" substructures in FORTRAN + which cannot be explicitly referenced, but the reference chain must be + considered as in C for backend translation to correctly compute layouts. + (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */ gfc_component * gfc_find_component (gfc_symbol *sym, const char *name, - bool noaccess, bool silent) + bool noaccess, bool silent, gfc_ref **ref) { - gfc_component *p; + gfc_component *p, *check; + gfc_ref *sref = NULL, *tmp = NULL; if (name == NULL || sym == NULL) return NULL; - sym = gfc_use_derived (sym); + if (sym->attr.flavor == FL_DERIVED) + sym = gfc_use_derived (sym); + else + gcc_assert (gfc_fl_struct (sym->attr.flavor)); if (sym == NULL) return NULL; + /* Handle UNIONs specially - mutually recursive with gfc_find_component. */ + if (sym->attr.flavor == FL_UNION) + return find_union_component (sym, name, noaccess, ref); + + if (ref) *ref = NULL; for (p = sym->components; p; p = p->next) - if (strcmp (p->name, name) == 0) - break; + { + /* Nest search into union's maps. */ + if (p->ts.type == BT_UNION) + { + check = find_union_component (p->ts.u.derived, name, noaccess, &tmp); + if (check != NULL) + { + /* Union ref. */ + if (ref) + { + sref = gfc_get_ref (); + sref->type = REF_COMPONENT; + sref->u.c.component = p; + sref->u.c.sym = p->ts.u.derived; + sref->next = tmp; + *ref = sref; + } + return check; + } + } + else if (strcmp (p->name, name) == 0) + break; + + continue; + } if (p && sym->attr.use_assoc && !noaccess) { @@ -2231,7 +2323,7 @@ gfc_find_component (gfc_symbol *sym, const char *name, && sym->components->ts.type == BT_DERIVED) { p = gfc_find_component (sym->components->ts.u.derived, name, - noaccess, silent); + noaccess, silent, ref); /* Do not overwrite the error. */ if (p == NULL) return p; @@ -2241,6 +2333,25 @@ gfc_find_component (gfc_symbol *sym, const char *name, gfc_error ("%qs at %C is not a member of the %qs structure", name, sym->name); + /* Component was found; build the ultimate component reference. */ + if (p != NULL && ref) + { + tmp = gfc_get_ref (); + tmp->type = REF_COMPONENT; + tmp->u.c.component = p; + tmp->u.c.sym = sym; + /* Link the final component ref to the end of the chain of subrefs. */ + if (sref) + { + *ref = sref; + for (; sref->next; sref = sref->next) + ; + sref->next = tmp; + } + else + *ref = tmp; + } + return p; } @@ -3338,11 +3449,9 @@ gfc_restore_last_undo_checkpoint (void) /* The derived type is saved in the symtree with the first letter capitalized; the all lower-case version to the derived type contains its associated generic function. */ - if (p->attr.flavor == FL_DERIVED) - gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s", - (char) TOUPPER ((unsigned char) p->name[0]), - &p->name[1])); - else + if (gfc_fl_struct (p->attr.flavor)) + gfc_delete_symtree (&p->ns->sym_root,gfc_dt_upper_string (p->name)); + else gfc_delete_symtree (&p->ns->sym_root, p->name); gfc_release_symbol (p); @@ -4526,10 +4635,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, const char *hidden_name; gfc_interface *intr, *head; - hidden_name = gfc_get_string ("%c%s", - (char) TOUPPER ((unsigned char) - tmp_sym->name[0]), - &tmp_sym->name[1]); + hidden_name = gfc_dt_upper_string (tmp_sym->name); tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, hidden_name); gcc_assert (tmp_symtree == NULL); @@ -4740,6 +4846,8 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) bool is_class2 = (ts2->type == BT_CLASS); bool is_derived1 = (ts1->type == BT_DERIVED); bool is_derived2 = (ts2->type == BT_DERIVED); + bool is_union1 = (ts1->type == BT_UNION); + bool is_union2 = (ts2->type == BT_UNION); if (is_class1 && ts1->u.derived->components @@ -4749,10 +4857,11 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) || ts1->u.derived->attr.unlimited_polymorphic)) return 1; - if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2) + if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2 + && !is_union1 && !is_union2) return (ts1->type == ts2->type); - if (is_derived1 && is_derived2) + if ((is_derived1 && is_derived2) || (is_union1 && is_union1)) return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); if (is_derived1 && is_class2) @@ -4821,12 +4930,12 @@ gfc_find_dt_in_generic (gfc_symbol *sym) { gfc_interface *intr = NULL; - if (!sym || sym->attr.flavor == FL_DERIVED) + if (!sym || gfc_fl_struct (sym->attr.flavor)) return sym; if (sym->attr.generic) for (intr = sym->generic; intr; intr = intr->next) - if (intr->sym->attr.flavor == FL_DERIVED) + if (gfc_fl_struct (intr->sym->attr.flavor)) break; return intr ? intr->sym : NULL; } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 309baf1c69e..d4ea6c8ee68 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -732,6 +732,7 @@ gfc_get_module_backend_decl (gfc_symbol *sym) st = NULL; s = NULL; + /* Check for a symbol with the same name. */ if (gsym) gfc_find_symbol (sym->name, gsym->ns, 0, &s); @@ -748,22 +749,37 @@ gfc_get_module_backend_decl (gfc_symbol *sym) st->n.sym = sym; sym->refs++; } - else if (sym->attr.flavor == FL_DERIVED) + else if (gfc_fl_struct (sym->attr.flavor)) { if (s && s->attr.flavor == FL_PROCEDURE) { gfc_interface *intr; gcc_assert (s->attr.generic); for (intr = s->generic; intr; intr = intr->next) - if (intr->sym->attr.flavor == FL_DERIVED) + if (gfc_fl_struct (intr->sym->attr.flavor)) { s = intr->sym; break; } } - if (!s->backend_decl) - s->backend_decl = gfc_get_derived_type (s); + /* Normally we can assume that s is a derived-type symbol since it + shares a name with the derived-type sym. However if sym is a + STRUCTURE, it may in fact share a name with any other basic type + variable. If s is in fact of derived type then we can continue + looking for a duplicate type declaration. */ + if (sym->attr.flavor == FL_STRUCT && s->ts.type == BT_DERIVED) + { + s = s->ts.u.derived; + } + + if (gfc_fl_struct (s->attr.flavor) && !s->backend_decl) + { + if (s->attr.flavor == FL_UNION) + s->backend_decl = gfc_get_union_type (s); + else + s->backend_decl = gfc_get_derived_type (s); + } gfc_copy_dt_decls_ifequal (s, sym, true); return true; } @@ -2384,7 +2400,7 @@ create_function_arglist (gfc_symbol * sym) Thus, we will use a hidden argument in that case. */ else if (f->sym->attr.optional && f->sym->attr.value && !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS - && f->sym->ts.type != BT_DERIVED) + && !gfc_bt_struct (f->sym->ts.type)) { tree tmp; strcpy (&name[1], f->sym->name); @@ -4596,7 +4612,7 @@ gfc_create_module_variable (gfc_symbol * sym) && sym->ts.type == BT_DERIVED) sym->backend_decl = gfc_typenode_for_spec (&(sym->ts)); - if (sym->attr.flavor == FL_DERIVED + if (gfc_fl_struct (sym->attr.flavor) && sym->backend_decl && TREE_CODE (sym->backend_decl) == RECORD_TYPE) { @@ -4839,7 +4855,7 @@ check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array, } else switch (ts->type) { - case BT_DERIVED: + case_bt_struct: if (expr->expr_type != EXPR_STRUCTURE) return false; cm = expr->ts.u.derived->components; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 8d039a670b5..8f84712931b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2297,6 +2297,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) tree tmp; tree decl; tree field; + tree context; c = ref->u.c.component; @@ -2307,15 +2308,20 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) field = c->backend_decl; gcc_assert (field && TREE_CODE (field) == FIELD_DECL); decl = se->expr; + context = DECL_FIELD_CONTEXT (field); /* Components can correspond to fields of different containing types, as components are created without context, whereas a concrete use of a component has the type of decl as context. So, if the type doesn't match, we search the corresponding FIELD_DECL in the parent type. To not waste too much time - we cache this result in norestrict_decl. */ + we cache this result in norestrict_decl. + On the other hand, if the context is a UNION or a MAP (a + RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */ - if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl)) + if (context != TREE_TYPE (decl) + && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */ + || TREE_CODE (context) == UNION_TYPE)) /* Field is map */ { tree f2 = c->norestrict_decl; if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl)) @@ -6715,7 +6721,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, { switch (ts->type) { - case BT_DERIVED: + case_bt_struct: case BT_CLASS: gfc_init_se (&se, NULL); if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL) @@ -6860,7 +6866,7 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, gfc_add_modify (&block, dest, se.expr); /* Deal with arrays of derived types with allocatable components. */ - if (cm->ts.type == BT_DERIVED + if (gfc_bt_struct (cm->ts.type) && cm->ts.u.derived->attr.alloc_comp) tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, dest, @@ -7033,7 +7039,7 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block, /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length component. */ sprintf (name, "_%s_length", cm->name); - strlen = gfc_find_component (sym, name, true, true); + strlen = gfc_find_component (sym, name, true, true, NULL); lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF, gfc_charlen_type_node, TREE_OPERAND (comp, 0), @@ -7245,7 +7251,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, fold_convert (TREE_TYPE (tmp), se.expr)); gfc_add_block_to_block (&block, &se.post); } - else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID) + else if (gfc_bt_struct (expr->ts.type) && expr->ts.f90_type != BT_VOID) { if (expr->expr_type != EXPR_STRUCTURE) { @@ -7416,6 +7422,24 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) return; } + /* Though unions appear to have multiple map components, they must only + have a single initializer since each map overlaps. TODO: squash map + constructors? */ + if (expr->ts.type == BT_UNION) + { + c = gfc_constructor_first (expr->value.constructor); + cm = c->n.component; + val = gfc_conv_initializer (c->expr, &expr->ts, + TREE_TYPE (cm->backend_decl), + cm->attr.dimension, cm->attr.pointer, + cm->attr.proc_pointer); + val = unshare_expr_without_location (val); + + /* Append it to the constructor list. */ + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + goto finish; + } + cm = expr->ts.u.derived->components; for (c = gfc_constructor_first (expr->value.constructor); @@ -7462,6 +7486,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); } } +finish: se->expr = build_constructor (type, v); if (init) TREE_CONSTANT (se->expr) = 1; @@ -8246,7 +8271,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen, rse->expr, ts.kind); } - else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) + else if (gfc_bt_struct (ts.type) && ts.u.derived->attr.alloc_comp) { tree tmp_var = NULL_TREE; cond = NULL_TREE; @@ -8299,7 +8324,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, gfc_add_expr_to_block (&block, tmp); } } - else if (ts.type == BT_DERIVED || ts.type == BT_CLASS) + else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS) { gfc_add_block_to_block (&block, &lse->pre); gfc_add_block_to_block (&block, &rse->pre); @@ -9503,7 +9528,7 @@ copyable_array_p (gfc_expr * expr) case BT_CHARACTER: return false; - case BT_DERIVED: + case_bt_struct: return !expr->ts.u.derived->attr.alloc_comp; default: diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 7f649978863..aefa96dfbbb 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -1685,7 +1685,7 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, gfc_add_expr_to_block (block, tmp); } - if (ts->type == BT_DERIVED && ts->u.derived->components) + if (gfc_bt_struct (ts->type) && ts->u.derived->components) { gfc_component *cmp; @@ -2211,7 +2211,7 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code) break; - case BT_DERIVED: + case_bt_struct: if (ts->u.derived->components == NULL) return; @@ -2330,7 +2330,7 @@ gfc_trans_transfer (gfc_code * code) gcc_assert (ref && ref->type == REF_ARRAY); } - if (expr->ts.type != BT_DERIVED + if (!gfc_bt_struct (expr->ts.type) && ref && ref->next == NULL && !is_subref_array (expr)) { diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 2fc43eddbe5..7d3cf8cae5a 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -6275,7 +6275,7 @@ gfc_trans_deallocate (gfc_code *code) { gfc_ref *ref; - if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp + if (gfc_bt_struct (expr->ts.type) && expr->ts.u.derived->attr.alloc_comp && !gfc_is_finalizable (expr->ts.u.derived, NULL)) { gfc_ref *last = NULL; diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index e6c5b8e8e91..0079d6cd422 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1102,6 +1102,10 @@ gfc_typenode_for_spec (gfc_typespec * spec) gfc_index_one_node); break; + case BT_UNION: + basetype = gfc_get_union_type (spec->u.derived); + break; + case BT_DERIVED: case BT_CLASS: basetype = gfc_get_derived_type (spec->u.derived); @@ -2315,7 +2319,9 @@ gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to, for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next) { to_cm->backend_decl = from_cm->backend_decl; - if (from_cm->ts.type == BT_DERIVED + if (from_cm->ts.type == BT_UNION) + gfc_get_union_type (to_cm->ts.u.derived); + else if (from_cm->ts.type == BT_DERIVED && (!from_cm->attr.pointer || from_gsym)) gfc_get_derived_type (to_cm->ts.u.derived); else if (from_cm->ts.type == BT_CLASS @@ -2350,6 +2356,62 @@ gfc_get_ppc_type (gfc_component* c) } +/* Build a tree node for a union type. Requires building each map + structure which is an element of the union. */ + +tree +gfc_get_union_type (gfc_symbol *un) +{ + gfc_component *map = NULL; + tree typenode = NULL, map_type = NULL, map_field = NULL; + tree *chain = NULL; + + if (un->backend_decl) + { + if (TYPE_FIELDS (un->backend_decl) || un->attr.proc_pointer_comp) + return un->backend_decl; + else + typenode = un->backend_decl; + } + else + { + typenode = make_node (UNION_TYPE); + TYPE_NAME (typenode) = get_identifier (un->name); + } + + /* Add each contained MAP as a field. */ + for (map = un->components; map; map = map->next) + { + gcc_assert (map->ts.type == BT_DERIVED); + + /* The map's type node, which is defined within this union's context. */ + map_type = gfc_get_derived_type (map->ts.u.derived); + TYPE_CONTEXT (map_type) = typenode; + + /* The map field's declaration. */ + map_field = gfc_add_field_to_struct(typenode, get_identifier(map->name), + map_type, &chain); + if (map->loc.lb) + gfc_set_decl_location (map_field, &map->loc); + else if (un->declared_at.lb) + gfc_set_decl_location (map_field, &un->declared_at); + + DECL_PACKED (map_field) |= TYPE_PACKED (typenode); + DECL_NAMELESS(map_field) = true; + + /* We should never clobber another backend declaration for this map, + because each map component is unique. */ + if (!map->backend_decl) + map->backend_decl = map_field; + } + + un->backend_decl = typenode; + gfc_finish_type (typenode); + + return typenode; +} + + /* Build a tree node for a derived type. If there are equal derived types, with different local names, these are built at the same time. If an equal derived type has been built @@ -2492,6 +2554,9 @@ 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_UNION && c->ts.u.derived->backend_decl == NULL) + c->ts.u.derived->backend_decl = gfc_get_union_type (c->ts.u.derived); + if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS) continue; @@ -2521,7 +2586,10 @@ gfc_get_derived_type (gfc_symbol * derived) return derived->backend_decl; /* Build the type member list. Install the newly created RECORD_TYPE - node as DECL_CONTEXT of each FIELD_DECL. */ + node as DECL_CONTEXT of each FIELD_DECL. In this case we must go + through only the top-level linked list of components so we correctly + build UNION_TYPE nodes for BT_UNION components. MAPs and other nested + types are built as part of gfc_get_union_type. */ for (c = derived->components; c; c = c->next) { /* Prevent infinite recursion, when the procedure pointer type is diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 585839c0c75..aab13e49b4a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,25 @@ +2016-05-07 Fritz Reese + + PR fortran/56226 + * gfortran.dg/dec_structure_1.f90: New testcase. + * gfortran.dg/dec_structure_2.f90: Ditto. + * gfortran.dg/dec_structure_3.f90: Ditto. + * gfortran.dg/dec_structure_4.f90: Ditto. + * gfortran.dg/dec_structure_5.f90: Ditto. + * gfortran.dg/dec_structure_6.f90: Ditto. + * gfortran.dg/dec_structure_7.f90: Ditto. + * gfortran.dg/dec_structure_8.f90: Ditto. + * gfortran.dg/dec_structure_9.f90: Ditto. + * gfortran.dg/dec_structure_10.f90: Ditto. + * gfortran.dg/dec_structure_11.f90: Ditto. + * gfortran.dg/dec_union_1.f90: Ditto. + * gfortran.dg/dec_union_2.f90: Ditto. + * gfortran.dg/dec_union_3.f90: Ditto. + * gfortran.dg/dec_union_4.f90: Ditto. + * gfortran.dg/dec_union_5.f90: Ditto. + * gfortran.dg/dec_union_6.f90: Ditto. + * gfortran.dg/dec_union_7.f90: Ditto. + 2016-05-07 Tom de Vries PR tree-optimization/70956 diff --git a/gcc/testsuite/gfortran.dg/dec_structure_1.f90 b/gcc/testsuite/gfortran.dg/dec_structure_1.f90 new file mode 100644 index 00000000000..4dfee3c602e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_structure_1.f90 @@ -0,0 +1,56 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Basic STRUCTURE test. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + call abort() +end subroutine + +! Basic structure +structure /s1/ ! type s1 + integer i1 + logical l1 + real r1 + character c1 +end structure ! end type s1 + +record /s1/ r1 ! type (s1) r1 +record /s1/ r1_a(3) ! type (s1) r1_a(3) + +! Basic records +r1.i1 = 13579 ! r1%i1 = ... +r1.l1 = .true. +r1.r1 = 13.579 +r1.c1 = 'F' +r1_a(2) = r1 +r1_a(3).r1 = 135.79 + +if (r1.i1 .ne. 13579) then + call aborts("r1.i1") +endif + +if (r1.l1 .neqv. .true.) then + call aborts("r1.l1") +endif + +if (r1.r1 .ne. 13.579) then + call aborts("r1.r1") +endif + +if (r1.c1 .ne. 'F') then + call aborts("r1.c1") +endif + +if (r1_a(2).i1 .ne. 13579) then + call aborts("r1_a(2).i1") +endif + +if (r1_a(3).r1 .ne. 135.79) then + call aborts("r1_a(3).r1") +endif + +end diff --git a/gcc/testsuite/gfortran.dg/dec_structure_10.f90 b/gcc/testsuite/gfortran.dg/dec_structure_10.f90 new file mode 100644 index 00000000000..2d92b1ad8fd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_structure_10.f90 @@ -0,0 +1,119 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Runtime tests for rules governing dot ('.') as a member accessor, including +! voodoo with aliased user-defined vs. intrinsic operators and nested members. +! See gcc/fortran/match.c (gfc_match_member_sep). +! + +module dec_structure_10 + ! Operator overload tests with .ne. and constant member + structure /s1/ + integer i + integer ne + logical b + end structure + + ! Operator overload tests with .eq., .test. and nested members + structure /s2/ + record /s1/ eq + record /s1/ test + record /s1/ and + integer i + end structure + + ! Deep nested access tests + structure /s3/ + record /s2/ r2 + end structure + structure /s4/ + record /s3/ r3 + end structure + structure /s5/ + record /s4/ r4 + end structure + structure /s6/ + record /s5/ r5 + end structure + structure /s7/ + record /s6/ r6 + end structure + + ! Operator overloads to mess with nested member accesses + interface operator (.ne.) + module procedure ne_func + end interface operator (.ne.) + interface operator (.eq.) + module procedure eq_func + end interface operator (.eq.) + interface operator (.test.) + module procedure tstfunc + end interface operator (.test.) + contains + ! ne_func will be called on (x) .ne. (y) + function ne_func (r, i) + integer, intent(in) :: i + type(s1), intent(in) :: r + integer ne_func + ne_func = r%i + i + end function + ! eq_func will be called on (x) .eq. (y) + function eq_func (r, i) + integer, intent(in) :: i + type(s2), intent(in) :: r + integer eq_func + eq_func = r%eq%i + i + end function eq_func + ! tstfunc will be called on (x) .test. (y) + function tstfunc (r, i) + integer, intent(in) :: i + type(s2), intent(in) :: r + integer tstfunc + tstfunc = r%i + i + end function tstfunc +end module + +use dec_structure_10 + +record /s1/ r +record /s2/ struct +record /s7/ r7 +integer i, j +logical l +struct%eq%i = 5 +i = -5 + +! Nested access: struct has a member and which has a member b +l = struct .and. b ! struct%and%b +l = struct .and. b .or. .false. ! (struct%and%b) .or. (.false.) + +! Intrinsic op: r has no member 'ne' +j = r .ne. i ! ne(r, i) +j = (r) .ne. i ! ne(r, i) + +! Intrinsic op; r has a member 'ne' but it is not a record +j = r .ne. i ! ne(r, i) +j = (r) .ne. i ! ne(r, i) + +! Nested access: struct has a member eq which has a member i +j = struct .eq. i ! struct%eq%i +if ( j .ne. struct%eq%i ) call abort() + +! User op: struct is compared to i with eq_func +j = (struct) .eq. i ! eq_func(struct, i) -> struct%eq%i + i +if ( j .ne. struct%eq%i + i ) call abort() + +! User op: struct has a member test which has a member i, but test is a uop +j = struct .test. i ! tstfunc(struct, i) -> struct%i + i +if ( j .ne. struct%i + i ) call abort() + +! User op: struct is compared to i with eq_func +j = (struct) .test. i ! tstfunc(struct, i) -> struct%i + i +if ( j .ne. struct%i + i ) call abort() + +! Deep nested access tests +r7.r6.r5.r4.r3.r2.i = 1337 +j = r7.r6.r5.r4.r3.r2.i +if ( j .ne. 1337 ) call abort() + +end diff --git a/gcc/testsuite/gfortran.dg/dec_structure_11.f90 b/gcc/testsuite/gfortran.dg/dec_structure_11.f90 new file mode 100644 index 00000000000..f6f5b6f9d13 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_structure_11.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! Tests for what CAN'T be done with dot ('.') as a member accessor. +! + +structure /s1/ + integer eq +end structure + +record /s1/ r +integer i, j, k + +j = i.j ! { dg-error "nonderived-type variable" } +j = r .eq. i ! { dg-error "Operands of comparison" } +j = r.i ! { dg-error "is not a member of" } +j = r. ! { dg-error "Expected structure component or operator name" } +j = .i ! { dg-error "Invalid character in name" } + +end diff --git a/gcc/testsuite/gfortran.dg/dec_structure_2.f90 b/gcc/testsuite/gfortran.dg/dec_structure_2.f90 new file mode 100644 index 00000000000..18db719c149 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_structure_2.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test STRUCTUREs containin other STRUCTUREs. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + call abort() +end subroutine + +! Basic structure +structure /s1/ + integer i1 + logical l1 + real r1 + character c1 +end structure + +structure /s2/ + integer i + record /s1/ r1 +endstructure + +record /s1/ r1 +record /s2/ r2, r2_a(10) + +! Nested and array records +r2.r1.r1 = 135.79 +r2_a(3).r1.i1 = -13579 + +if (r2.r1.r1 .ne. 135.79) then + call aborts("r1.r1.r1") +endif + +if (r2_a(3).r1.i1 .ne. -13579) then + call aborts("r2_a(3).r1.i1") +endif + +end diff --git a/gcc/testsuite/gfortran.dg/dec_structure_3.f90 b/gcc/testsuite/gfortran.dg/dec_structure_3.f90 new file mode 100644 index 00000000000..9cb7adb6719 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_structure_3.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test nested STRUCTURE definitions. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + call abort() +end subroutine + +structure /s3/ + real p + structure /s4/ recrd, recrd_a(3) + integer i, j + end structure + real q +end structure + +record /s3/ r3 +record /s4/ r4 + +r3.p = 1.3579 +r4.i = 0 +r4.j = 1 +r3.recrd = r4 +r3.recrd_a(1) = r3.recrd +r3.recrd_a(2).i = 1 +r3.recrd_a(2).j = 0 + +if (r3.p .ne. 1.3579) then + call aborts("r3.p") +endif + +if (r4.i .ne. 0) then + call aborts("r4.i") +endif + +if (r4.j .ne. 1) then + call aborts("r4.j") +endif + +if (r3.recrd.i .ne. 0 .or. r3.recrd.j .ne. 1) then + call aborts("r3.recrd") +endif + +if (r3.recrd_a(2).i .ne. 1 .or. r3.recrd_a(2).j .ne. 0) then + call aborts("r3.recrd_a(2)") +endif + +end diff --git a/gcc/testsuite/gfortran.dg/dec_structure_4.f90 b/gcc/testsuite/gfortran.dg/dec_structure_4.f90 new file mode 100644 index 00000000000..a941c220b7e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_structure_4.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test anonymous STRUCTURE definitions. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + call abort() +end subroutine + +structure /s5/ + structure recrd, recrd_a(3) + real x, y + end structure +end structure + +record /s5/ r5 + +r5.recrd.x = 1.3 +r5.recrd.y = 5.7 +r5.recrd_a(1) = r5.recrd +r5.recrd_a(2).x = 5.7 +r5.recrd_a(2).y = 1.3 + +if (r5.recrd.x .ne. 1.3) then + call aborts("r5.recrd.x") +endif + +if (r5.recrd.y .ne. 5.7) then + call aborts("r5.recrd.y") +endif + +if (r5.recrd_a(1).x .ne. 1.3 .or. r5.recrd_a(1).y .ne. 5.7) then + call aborts("r5.recrd_a(1)") +endif + +if (r5.recrd_a(2).x .ne. 5.7 .or. r5.recrd_a(2).y .ne. 1.3) then + call aborts("r5.recrd_a(2)") +endif + +end diff --git a/gcc/testsuite/gfortran.dg/dec_structure_5.f90 b/gcc/testsuite/gfortran.dg/dec_structure_5.f90 new file mode 100644 index 00000000000..abda3c3e9fb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_structure_5.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test STRUCTUREs which share names with variables. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + call abort() +end subroutine + +! Special regression where shared names within a module caused an ICE +! from gfc_get_module_backend_decl +module dec_structure_5m + structure /s6/ + integer i + end structure + + record /s6/ s6 +end module + +program dec_structure_5 + use dec_structure_5m + + structure /s7/ + real r + end structure + + record /s7/ s7(3) + + s6.i = 0 + s7(1).r = 1.0 + s7(2).r = 2.0 + s7(3).r = 3.0 + + if (s6.i .ne. 0) then + call aborts("s6.i") + endif + + if (s7(1).r .ne. 1.0) then + call aborts("s7(1).r") + endif + + if (s7(2).r .ne. 2.0) then + call aborts("s7(2).r") + endif + +end diff --git a/gcc/testsuite/gfortran.dg/dec_structure_6.f90 b/gcc/testsuite/gfortran.dg/dec_structure_6.f90 new file mode 100644 index 00000000000..6494d71fd1c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_structure_6.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test old-style CLIST initializers in STRUCTURE. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + call abort() +end subroutine + +integer, parameter :: as = 3 +structure /s8/ + character*20 c /"HELLO"/ ! ok + integer*2 j /300_4/ ! ok, converted + integer k /65536_8/ ! ok, implicit + integer*4 l /200000/ ! ok, types match + integer m(5) /5,4,3,2,1/! ok + integer n(5) /1,3*2,1/ ! ok, with repeat spec (/1,2,2,2,1/) + integer o(as) /as*9/ ! ok, parameter array spec + integer p(2,2) /1,2,3,4/! ok + real q(3) /1_2,3.5,2.4E-12_8/ ! ok, with some implicit conversions + integer :: canary = z'3D3D3D3D' +end structure + +record /s8/ r8 + +! Old-style (clist) initializers in structures +if ( r8.c /= "HELLO" ) call aborts ("r8.c") +if ( r8.j /= 300 ) call aborts ("r8.j") +if ( r8.k /= 65536 ) call aborts ("r8.k") +if ( r8.l /= 200000 ) call aborts ("r8.l") +if ( r8.m(1) /= 5 .or. r8.m(2) /= 4 .or. r8.m(3) /= 3 & + .or. r8.m(4) /= 2 .or. r8.m(5) /= 1) & + call aborts ("r8.m") +if ( r8.n(1) /= 1 .or. r8.n(2) /= 2 .or. r8.n(3) /= 2 .or. r8.n(4) /= 2 & + .or. r8.n(5) /= 1) & + call aborts ("r8.n") +if ( r8.o(1) /= 9 .or. r8.o(2) /= 9 .or. r8.o(3) /= 9 ) call aborts ("r8.o") +if ( r8.p(1,1) /= 1 .or. r8.p(2,1) /= 2 .or. r8.p(1,2) /= 3 & + .or. r8.p(2,2) /= 4) & + call aborts ("r8.p") +if ( r8.canary /= z'3D3D3D3D' ) call aborts ("r8.canary") + +end diff --git a/gcc/testsuite/gfortran.dg/dec_structure_7.f90 b/gcc/testsuite/gfortran.dg/dec_structure_7.f90 new file mode 100644 index 00000000000..baba1ef2b5f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_structure_7.f90 @@ -0,0 +1,75 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test passing STRUCTUREs through functions and subroutines. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + call abort() +end subroutine + +module dec_structure_7m + structure /s1/ + integer i1 + logical l1 + real r1 + character c1 + end structure + + structure /s2/ + integer i + record /s1/ r1 + endstructure + +contains + ! Pass structure through subroutine + subroutine sub (rec1, i) + implicit none + integer, intent(in) :: i + record /s1/ rec1 + rec1.i1 = i + end subroutine + + ! Pass structure through function + function func (rec2, r) + implicit none + real, intent(in) :: r + record /s2/ rec2 + real func + rec2.r1.r1 = r + func = rec2.r1.r1 + return + end function +end module + +program dec_structure_7 + use dec_structure_7m + + implicit none + record /s1/ r1 + record /s2/ r2 + real junk + + ! Passing through functions and subroutines + r1.i1 = 0 + call sub (r1, 10) + + r2.r1.r1 = 0.0 + junk = func (r2, -20.14) + + if (r1.i1 .ne. 10) then + call aborts("sub(r1, 10)") + endif + + if (r2.r1.r1 .ne. -20.14) then + call aborts("func(r2, -20.14)") + endif + + if (junk .ne. -20.14) then + print *, junk + call aborts("junk = func()") + endif + +end program diff --git a/gcc/testsuite/gfortran.dg/dec_structure_8.f90 b/gcc/testsuite/gfortran.dg/dec_structure_8.f90 new file mode 100644 index 00000000000..160b92a8b96 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_structure_8.f90 @@ -0,0 +1,60 @@ +! { dg-do compile } +! { dg-options "-fdec-structure -fmax-errors=0" } +! +! Comprehensive compile tests for what structures CAN'T do. +! + +! Old-style (clist) initialization +integer,parameter :: as = 3 +structure /t1/ + integer*1 a /300_2/ ! { dg-error "Arithmetic overflow" } + integer b // ! { dg-error "Empty old style initializer list" } + integer c /2*3/ ! { dg-error "Repeat spec invalid in scalar" } + integer d /1,2,3/ ! { dg-error "End of scalar initializer expected" } + integer e /"HI"/ ! { dg-error "Can't convert" } + integer f(as) /4*9/ ! { dg-error "Too many elements" } + integer g(3) /1,3/ ! { dg-error "Not enough elements" } + integer h(3) /1,3,5,7/ ! { dg-error "Too many elements" } + integer i(3) /2*1/ ! { dg-error "Not enough elements" } + integer j(3) /10*1/ ! { dg-error "Too many elements" } + integer k(3) /2.5*3/ ! { dg-error "Repeat spec must be an integer" } + integer l(2) /2*/ ! { dg-error "Expected data constant" } + integer m(1) / ! { dg-error "Syntax error in old style" } + integer n(2) /1 ! { dg-error "Syntax error in old style" } + integer o(2) /1, ! { dg-error "Syntax error in old style" } + integer p(1) /x/ ! { dg-error "must be a PARAMETER" } +end structure + +structure ! { dg-error "Structure name expected" } +structure / ! { dg-error "Structure name expected" } +structure // ! { dg-error "Structure name expected" } +structure /.or./ ! { dg-error "Structure name expected" } +structure /integer/ ! { dg-error "Structure name.*cannot be the same" } +structure /foo/ bar ! { dg-error "Junk after" } +structure /t1/ ! { dg-error "Type definition.*T1" } + +record ! { dg-error "Structure name expected" } +record bar ! { dg-error "Structure name expected" } +record / bar ! { dg-error "Structure name expected" } +record // bar ! { dg-error "Structure name expected" } +record foo/ bar ! { dg-error "Structure name expected" } +record /foo bar ! { dg-error "Structure name expected" } +record /foo/ bar ! { dg-error "used before it is defined" } +record /t1/ ! { dg-error "Invalid character in name" } + +structure /t2/ + ENTRY here ! { dg-error "ENTRY statement.*cannot appear" } + integer a + integer a ! { dg-error "Component.*already declared" } + structure $z ! { dg-error "Invalid character in name" } + structure // ! { dg-error "Invalid character in name" } + structure // x ! { dg-error "Invalid character in name" } + structure /t3/ ! { dg-error "Invalid character in name" } + structure /t3/ x,$y ! { dg-error "Invalid character in name" } + structure /t4/ y + integer i, j, k + end structure + structure /t4/ z ! { dg-error "Type definition.*T4" } +end structure + +end diff --git a/gcc/testsuite/gfortran.dg/dec_structure_9.f90 b/gcc/testsuite/gfortran.dg/dec_structure_9.f90 new file mode 100644 index 00000000000..34c46c61c1c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_structure_9.f90 @@ -0,0 +1,42 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! Basic compile tests for what CAN be done with dot ('.') as a member accessor. +! + +logical :: l, l2 = .true., l3 = .false., and +integer i +character(5) s +real r + +structure /s1/ + integer i + character(5) s + real r +end structure + +record /s1/ r1 + +! Basic +l = l .and. l2 .or. l3 +l = and .and. and .and. and +l = l2 .eqv. l3 +l = (l2) .eqv. l3 + +! Integers +l = .not. (i .eq. 0) +l = .not. (0 .eq. i) +l = .not. (r1.i .eq. 0) +l = .not. (0 .eq. r1.i) +! Characters +l = .not. (s .eq. "hello") +l = .not. ("hello" .eq. s) +l = .not. (r1.s .eq. "hello") +l = .not. ("hello" .eq. r1.s) +! Reals +l = .not. (r .eq. 3.14) +l = .not. (3.14 .eq. r) +l = .not. (r1.r .eq. 3.14) +l = .not. (3.14 .eq. r1.r) + +end diff --git a/gcc/testsuite/gfortran.dg/dec_union_1.f90 b/gcc/testsuite/gfortran.dg/dec_union_1.f90 new file mode 100644 index 00000000000..36af53adfe1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_union_1.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test whether union backend declarations are corrently _not_ copied when they +! are not in fact equal. The structure defined in sub() is seen later, but +! where siz has a different value. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + call abort() +end subroutine + +subroutine sub () + integer, parameter :: siz = 1024 + structure /s6/ + union ! U0 + map ! M0 + integer ibuf(siz) + end map + map ! M1 + character(8) cbuf(siz) + end map + map ! M2 + real rbuf(siz) + end map + end union + end structure + record /s6/ r6 + r6.ibuf(1) = z'badbeef' + r6.ibuf(2) = z'badbeef' +end subroutine + +! Repeat definition from subroutine sub with different size parameter. +! If the structure definition is copied here the stack may get messed up. +integer, parameter :: siz = 65536 +structure /s6/ + union ! U12 + map + integer ibuf(siz) + end map + map + character(8) cbuf(siz) + end map + map + real rbuf(siz) + end map + end union +end structure + +record /s6/ r6 +integer :: r6_canary = 0 + +! Copied type declaration - this should not cause problems +i = 1 +do while (i < siz) + r6.ibuf(i) = z'badbeef' + i = i + 1 +end do + +if ( r6_canary .ne. 0 ) then + call aborts ('copied decls: overflow') +endif + +end diff --git a/gcc/testsuite/gfortran.dg/dec_union_2.f90 b/gcc/testsuite/gfortran.dg/dec_union_2.f90 new file mode 100644 index 00000000000..61e4fd8bd80 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_union_2.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test basic UNION implementation. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + call abort() +end subroutine + +! Empty union +structure /s0/ + union ! U0 + map ! M0 + end map + map ! M1 + end map + end union +end structure + +! Basic unions +structure /s1/ + union ! U1 + map ! M2 + integer(4) a + end map + map ! M3 + real(4) b + end map + end union +end structure +structure /s2/ + union ! U2 + map ! M4 + integer(2) w1, w2 + end map + map ! M5 + integer(4) long + end map + end union +end structure + +record /s1/ r1 +record /s2/ r2 + +! Basic unions +r1.a = 0 +r1.b = 1.33e7 +if ( r1.a .eq. 0 ) call aborts ("basic union 1") + +! Endian-agnostic runtime check +r2.long = z'12345678' +if (.not. ( (r2.w1 .eq. z'1234' .and. r2.w2 .eq. z'5678') & + .or. (r2.w1 .eq. z'5678' .and. r2.w2 .eq. z'1234')) ) then + call aborts ("basic union 2") +endif + +end diff --git a/gcc/testsuite/gfortran.dg/dec_union_3.f90 b/gcc/testsuite/gfortran.dg/dec_union_3.f90 new file mode 100644 index 00000000000..ce5ae797859 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_union_3.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test UNIONs with initializations. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + call abort() +end subroutine + +! Initialization expressions +structure /s3/ + integer(4) :: i = 8 + union ! U7 + map + integer(4) :: x = 1600 + integer(4) :: y = 1800 + end map + map + integer(2) a, b, c + end map + end union +end structure + +record /s3/ r3 + +! Initialized unions +if ( r3.x .ne. 1600 .or. r3.y .ne. 1800) then + r3.x = r3.y ! If r3 isn't used the initializations are optimized out + call aborts ("union initialization") +endif + +end diff --git a/gcc/testsuite/gfortran.dg/dec_union_4.f90 b/gcc/testsuite/gfortran.dg/dec_union_4.f90 new file mode 100644 index 00000000000..3bf6d618a8e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_union_4.f90 @@ -0,0 +1,62 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test nested UNIONs. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + call abort() +end subroutine + +! Nested unions +structure /s4/ + union ! U0 ! rax + map + integer(8) rx + end map + map + integer(4) rh ! rah + union ! U1 + map + integer(4) rl ! ral + end map + map + integer(4) ex ! eax + end map + map + integer(2) eh ! eah + union ! U2 + map + integer(2) el ! eal + end map + map + integer(2) x ! ax + end map + map + integer(1) h ! ah + integer(1) l ! al + end map + end union + end map + end union + end map + end union +end structure +record /s4/ r4 + + +! Nested unions +r4.rx = z'7A7B7CCC7FFFFFFF' +if ( r4.rx .ne. z'7A7B7CCC7FFFFFFF' ) call aborts ("rax") +if ( r4.rh .ne. z'7FFFFFFF' ) call aborts ("rah") +if ( r4.rl .ne. z'7A7B7CCC' ) call aborts ("ral") +if ( r4.ex .ne. z'7A7B7CCC' ) call aborts ("eax") +if ( r4.eh .ne. z'7CCC' ) call aborts ("eah") +if ( r4.el .ne. z'7A7B' ) call aborts ("eal") +if ( r4.x .ne. z'7A7B' ) call aborts ("ax") +if ( r4.h .ne. z'7B' ) call aborts ("ah") +if ( r4.l .ne. z'7A' ) call aborts ("al") + +end diff --git a/gcc/testsuite/gfortran.dg/dec_union_5.f90 b/gcc/testsuite/gfortran.dg/dec_union_5.f90 new file mode 100644 index 00000000000..bb1611a0289 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_union_5.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test UNIONs with array components. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + call abort() +end subroutine + +! Unions with arrays +structure /s5/ + union + map + character :: s(5) + end map + map + integer(1) :: a(5) + end map + end union +end structure + +record /s5/ r5 + +! Unions with arrays +r5.a(1) = z'41' +r5.a(2) = z'42' +r5.a(3) = z'43' +r5.a(4) = z'44' +r5.a(5) = z'45' +if ( r5.s(1) .ne. 'A' & + .or. r5.s(2) .ne. 'B' & + .or. r5.s(3) .ne. 'C' & + .or. r5.s(4) .ne. 'D' & + .or. r5.s(5) .ne. 'E') then + call aborts ("arrays") +endif + +end diff --git a/gcc/testsuite/gfortran.dg/dec_union_6.f90 b/gcc/testsuite/gfortran.dg/dec_union_6.f90 new file mode 100644 index 00000000000..31059c46880 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_union_6.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! sub0 and sub1 test a regression where calling gfc_use_derived from +! gfc_find_component on the structure type symbol being parsed caused the +! symbol to be freed and swapped for the previously seen type symbol, leaving +! dangling pointers and causing all sorts of mayhem. +! + +subroutine sub0 (u) + structure /s/ + union ! U0 + map ! M0 + integer i + end map + end union + end structure + record /s/ u + u.i = 0 +end subroutine sub0 + +subroutine sub1 () + structure /s/ + union ! U1 + map ! M1 + integer i + end map + end union + end structure + record /s/ u + interface ! matches the declaration of sub0 above + subroutine sub0 (u) + structure /s/ + union ! U2 + map ! M2 + integer i ! gfc_find_component should not call gfc_use_derived + end map ! here, otherwise this structure's type symbol is freed + end union ! out from under it + end structure + record /s/ u + end subroutine sub0 + end interface + call sub0(u) +end subroutine + +! If sub0 and sub1 aren't used they may be omitted +structure /s/ + union ! U1 + map ! M3 + integer i + end map + end union +end structure +record /s/ u + +call sub0(u) +call sub1() + +end diff --git a/gcc/testsuite/gfortran.dg/dec_union_7.f90 b/gcc/testsuite/gfortran.dg/dec_union_7.f90 new file mode 100644 index 00000000000..270f0fbd415 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_union_7.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! Comprehensive compile tests for what unions CAN'T do. +! + +! Syntax errors +structure /s0/ + union a b c ! { dg-error "Junk after UNION" } + union + map a b c ! { dg-error "Junk after MAP" } + integer x ! { dg-error "Unexpected" } + structure /s2/ ! { dg-error "Unexpected" } + map + map ! { dg-error "Unexpected" } + end map + end union +end structure + +! Initialization expressions +structure /s1/ + union + map + integer(4) :: x = 1600 ! { dg-error "Conflicting initializers" } + integer(4) :: y = 1800 + end map + map + integer(2) a, b, c, d + integer :: e = 0 ! { dg-error "Conflicting initializers" } + end map + map + real :: p = 1.3, q = 3.7 ! { dg-error "Conflicting initializers" } + end map + end union +end structure +record /s1/ r1 + +end