From 18a4e7e305c1e12392ac35073b89f2ca0e7f8eda Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Tue, 12 Sep 2017 18:06:52 +0000 Subject: [PATCH] re PR fortran/82173 ([meta-bug] Parameterized derived type errors) 2017-09-12 Paul Thomas PR fortran/82173 PR fortran/82168 * decl.c (variable_decl): Check pdt template components for appearance of KIND/LEN components in the type parameter name list, that components corresponding to type parameters have either KIND or LEN attributes and that KIND or LEN components are scalar. Copy the initializer to the parameter value. (gfc_get_pdt_instance): Add a label 'error_return' and follow it with repeated code, while replacing this code with a jump. Check if a parameter appears as a component in the template. Make sure that the parameter expressions are integer. Validate KIND expressions. (gfc_match_decl_type_spec): Search for pdt_types in the parent namespace since they are instantiated in the template ns. * expr.c (gfc_extract_int): Use a KIND parameter if it appears as a component expression. (gfc_check_init_expr): Allow expressions with the pdt_kind attribute. *primary.c (gfc_match_actual_arglist): Make sure that the first keyword argument is recognised when 'pdt' is set. 2017-09-12 Paul Thomas PR fortran/82173 * gfortran.dg/pdt_4.f03 : Remove the 'is being used before it is defined' error. * gfortran.dg/pdt_6.f03 : New test. * gfortran.dg/pdt_7.f03 : New test. * gfortran.dg/pdt_8.f03 : New test. PR fortran/82168 * gfortran.dg/pdt_9.f03 : New test. From-SVN: r252039 --- gcc/fortran/ChangeLog | 23 +++++ gcc/fortran/decl.c | 126 +++++++++++++++++++++++----- gcc/fortran/expr.c | 16 +++- gcc/fortran/primary.c | 14 ++-- gcc/fortran/symbol.c | 86 +++++++++---------- gcc/testsuite/ChangeLog | 12 +++ gcc/testsuite/gfortran.dg/pdt_4.f03 | 4 +- gcc/testsuite/gfortran.dg/pdt_6.f03 | 26 ++++++ gcc/testsuite/gfortran.dg/pdt_7.f03 | 20 +++++ gcc/testsuite/gfortran.dg/pdt_8.f03 | 23 +++++ gcc/testsuite/gfortran.dg/pdt_9.f03 | 23 +++++ 11 files changed, 303 insertions(+), 70 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pdt_6.f03 create mode 100644 gcc/testsuite/gfortran.dg/pdt_7.f03 create mode 100644 gcc/testsuite/gfortran.dg/pdt_8.f03 create mode 100644 gcc/testsuite/gfortran.dg/pdt_9.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 20fae5ae804..4db5051e0ed 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,26 @@ +2017-09-12 Paul Thomas + + PR fortran/82173 + PR fortran/82168 + * decl.c (variable_decl): Check pdt template components for + appearance of KIND/LEN components in the type parameter name + list, that components corresponding to type parameters have + either KIND or LEN attributes and that KIND or LEN components + are scalar. Copy the initializer to the parameter value. + (gfc_get_pdt_instance): Add a label 'error_return' and follow + it with repeated code, while replacing this code with a jump. + Check if a parameter appears as a component in the template. + Make sure that the parameter expressions are integer. Validate + KIND expressions. + (gfc_match_decl_type_spec): Search for pdt_types in the parent + namespace since they are instantiated in the template ns. + * expr.c (gfc_extract_int): Use a KIND parameter if it + appears as a component expression. + (gfc_check_init_expr): Allow expressions with the pdt_kind + attribute. + *primary.c (gfc_match_actual_arglist): Make sure that the first + keyword argument is recognised when 'pdt' is set. + 2017-09-10 Paul Thomas PR fortran/34640 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 0609152477d..6e78d0d0e49 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -2537,6 +2537,39 @@ variable_decl (int elem) goto cleanup; } + if (gfc_current_state () == COMP_DERIVED + && gfc_current_block ()->attr.pdt_template) + { + gfc_symbol *param; + gfc_find_symbol (name, gfc_current_block ()->f2k_derived, + 0, ¶m); + if (!param && (current_attr.pdt_kind || current_attr.pdt_len)) + { + gfc_error ("The component with KIND or LEN attribute at %C does not " + "not appear in the type parameter list at %L", + &gfc_current_block ()->declared_at); + m = MATCH_ERROR; + goto cleanup; + } + else if (param && !(current_attr.pdt_kind || current_attr.pdt_len)) + { + gfc_error ("The component at %C that appears in the type parameter " + "list at %L has neither the KIND nor LEN attribute", + &gfc_current_block ()->declared_at); + m = MATCH_ERROR; + goto cleanup; + } + else if (as && (current_attr.pdt_kind || current_attr.pdt_len)) + { + gfc_error ("The component at %C which is a type parameter must be " + "a scalar"); + m = MATCH_ERROR; + goto cleanup; + } + else if (param && initializer) + param->value = gfc_copy_expr (initializer); + } + /* 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. */ @@ -3193,8 +3226,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, { gfc_error ("The type parameter spec list at %C cannot contain " "both ASSUMED and DEFERRED parameters"); - gfc_free_actual_arglist (type_param_spec_list); - return MATCH_ERROR; + goto error_return; } } @@ -3202,10 +3234,27 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, name_seen = true; param = type_param_name_list->sym; + c1 = gfc_find_component (pdt, param->name, false, true, NULL); + if (!pdt->attr.use_assoc && !c1) + { + gfc_error ("The type parameter name list at %L contains a parameter " + "'%qs' , which is not declared as a component of the type", + &pdt->declared_at, param->name); + goto error_return; + } + kind_expr = NULL; if (!name_seen) { - if (actual_param && actual_param->spec_type == SPEC_EXPLICIT) + if (!actual_param && !(c1 && c1->initializer)) + { + gfc_error ("The type parameter spec list at %C does not contain " + "enough parameter expressions"); + goto error_return; + } + else if (!actual_param && c1 && c1->initializer) + kind_expr = gfc_copy_expr (c1->initializer); + else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT) kind_expr = gfc_copy_expr (actual_param->expr); } else @@ -3225,7 +3274,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, { gfc_error ("The derived parameter '%qs' at %C does not " "have a default value", param->name); - return MATCH_ERROR; + goto error_return; } } } @@ -3247,6 +3296,17 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, if (kind_expr) { + /* Variable expressions seem to default to BT_PROCEDURE. + TODO find out why this is and fix it. */ + if (kind_expr->ts.type != BT_INTEGER + && kind_expr->ts.type != BT_PROCEDURE) + { + gfc_error ("The parameter expression at %C must be of " + "INTEGER type and not %s type", + gfc_basic_typename (kind_expr->ts.type)); + goto error_return; + } + tail->expr = gfc_copy_expr (kind_expr); /* Try simplification even for LEN expressions. */ gfc_simplify_expr (tail->expr, 1); @@ -3257,7 +3317,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, if (!param->attr.pdt_kind) { - if (!name_seen) + if (!name_seen && actual_param) actual_param = actual_param->next; if (kind_expr) { @@ -3273,16 +3333,14 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, { gfc_error ("The KIND parameter '%qs' at %C cannot either be " "ASSUMED or DEFERRED", param->name); - gfc_free_actual_arglist (type_param_spec_list); - return MATCH_ERROR; + goto error_return; } if (!kind_expr || !gfc_is_constant_expr (kind_expr)) { gfc_error ("The value for the KIND parameter '%qs' at %C does not " "reduce to a constant expression", param->name); - gfc_free_actual_arglist (type_param_spec_list); - return MATCH_ERROR; + goto error_return; } gfc_extract_int (kind_expr, &kind_value); @@ -3293,12 +3351,19 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, gfc_free_expr (kind_expr); } + if (!name_seen && actual_param) + { + gfc_error ("The type parameter spec list at %C contains too many " + "parameter expressions"); + goto error_return; + } + /* Now we search for the PDT instance 'name'. If it doesn't exist, we build it, using 'pdt' as a template. */ if (gfc_get_symbol (name, pdt->ns, &instance)) { gfc_error ("Parameterized derived type at %C is ambiguous"); - return MATCH_ERROR; + goto error_return; } m = MATCH_YES; @@ -3370,7 +3435,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, gfc_error ("Maximum extension level reached with type %qs at %L", c2->ts.u.derived->name, &c2->ts.u.derived->declared_at); - return MATCH_ERROR; + goto error_return; } instance->attr.extension = c2->ts.u.derived->attr.extension + 1; @@ -3390,6 +3455,12 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, gfc_insert_kind_parameter_exprs (e); gfc_extract_int (e, &c2->ts.kind); gfc_free_expr (e); + if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0) + { + gfc_error ("Kind %d not supported for type %s at %C", + c2->ts.kind, gfc_basic_typename (c2->ts.type)); + goto error_return; + } } /* Similarly, set the string length if parameterized. */ @@ -3499,6 +3570,10 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, *ext_param_list = type_param_spec_list; *sym = instance; return m; + +error_return: + gfc_free_actual_arglist (type_param_spec_list); + return MATCH_ERROR; } @@ -3829,6 +3904,19 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) } if (sym->generic && !dt_sym) dt_sym = gfc_find_dt_in_generic (sym); + + /* Host associated PDTs can get confused with their constructors + because they ar instantiated in the template's namespace. */ + if (!dt_sym) + { + if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym)) + { + gfc_error ("Type name %qs at %C is ambiguous", name); + return MATCH_ERROR; + } + if (dt_sym && !dt_sym->attr.pdt_type) + dt_sym = NULL; + } } else if (ts->kind == -1) { @@ -3861,14 +3949,14 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) if (sym && sym->attr.flavor == FL_DERIVED && sym->attr.pdt_template && gfc_current_state () != COMP_DERIVED) - { - m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL); - if (m != MATCH_YES) - return m; - gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type); - ts->u.derived = sym; - strcpy (name, gfc_dt_lower_string (sym->name)); - } + { + m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL); + if (m != MATCH_YES) + return m; + gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type); + ts->u.derived = sym; + strcpy (name, gfc_dt_lower_string (sym->name)); + } gfc_save_symbol_data (sym); gfc_set_sym_referenced (sym); diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 35df29c6652..87ea09f03d6 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -624,6 +624,20 @@ gfc_replace_expr (gfc_expr *dest, gfc_expr *src) bool gfc_extract_int (gfc_expr *expr, int *result, int report_error) { + gfc_ref *ref; + + /* A KIND component is a parameter too. The expression for it + is stored in the initializer and should be consistent with + the tests below. */ + if (gfc_expr_attr(expr).pdt_kind) + { + for (ref = expr->ref; ref; ref = ref->next) + { + if (ref->u.c.component->attr.pdt_kind) + expr = ref->u.c.component->initializer; + } + } + if (expr->expr_type != EXPR_CONSTANT) { if (report_error > 0) @@ -2548,7 +2562,7 @@ gfc_check_init_expr (gfc_expr *e) t = true; /* This occurs when parsing pdt templates. */ - if (e->symtree->n.sym->attr.pdt_kind) + if (gfc_expr_attr (e).pdt_kind) break; if (gfc_check_iter_variable (e)) diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 883141fe565..25658d7c650 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1796,11 +1796,6 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt) if (sub_flag && !pdt && gfc_match_char ('*') == MATCH_YES) { - if (pdt) - { - tail->spec_type = SPEC_ASSUMED; - goto next; - } m = gfc_match_st_label (&label); if (m == MATCH_NO) gfc_error ("Expected alternate return label at %C"); @@ -1829,6 +1824,15 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt) } else tail->spec_type = SPEC_EXPLICIT; + + m = match_keyword_arg (tail, head, pdt); + if (m == MATCH_YES) + { + seen_keyword = 1; + goto next; + } + if (m == MATCH_ERROR) + goto cleanup; } /* After the first keyword argument is seen, the following diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 61ee94bdd66..68a76c4e4cf 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -308,7 +308,7 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns) sym->ts.f90_type = sym->ts.type; } } - + return true; } @@ -464,7 +464,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) case FL_NAMELIST: gfc_error ("Namelist group name at %L cannot have the " "SAVE attribute", where); - return false; + return false; case FL_PROCEDURE: /* Conflicts between SAVE and PROCEDURE will be checked at resolution stage, see "resolve_fl_procedure". */ @@ -513,7 +513,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained) conf (external, subroutine); - if (attr->proc_pointer && !gfc_notify_std (GFC_STD_F2003, + if (attr->proc_pointer && !gfc_notify_std (GFC_STD_F2003, "Procedure pointer at %C")) return false; @@ -1197,8 +1197,8 @@ gfc_add_protected (symbol_attribute *attr, const char *name, locus *where) if (attr->is_protected) { - if (!gfc_notify_std (GFC_STD_LEGACY, - "Duplicate PROTECTED attribute specified at %L", + if (!gfc_notify_std (GFC_STD_LEGACY, + "Duplicate PROTECTED attribute specified at %L", where)) return false; } @@ -1241,8 +1241,8 @@ gfc_add_save (symbol_attribute *attr, save_state s, const char *name, if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT) { - if (!gfc_notify_std (GFC_STD_LEGACY, - "Duplicate SAVE attribute specified at %L", + if (!gfc_notify_std (GFC_STD_LEGACY, + "Duplicate SAVE attribute specified at %L", where)) return false; } @@ -1261,8 +1261,8 @@ gfc_add_value (symbol_attribute *attr, const char *name, locus *where) if (attr->value) { - if (!gfc_notify_std (GFC_STD_LEGACY, - "Duplicate VALUE attribute specified at %L", + if (!gfc_notify_std (GFC_STD_LEGACY, + "Duplicate VALUE attribute specified at %L", where)) return false; } @@ -1280,8 +1280,8 @@ gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where) given a VOLATILE attribute - unless it is a coarray (F2008, C560). */ if (attr->volatile_ && attr->volatile_ns == gfc_current_ns) - if (!gfc_notify_std (GFC_STD_LEGACY, - "Duplicate VOLATILE attribute specified at %L", + if (!gfc_notify_std (GFC_STD_LEGACY, + "Duplicate VOLATILE attribute specified at %L", where)) return false; @@ -1299,8 +1299,8 @@ gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where) given a ASYNCHRONOUS attribute. */ if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns) - if (!gfc_notify_std (GFC_STD_LEGACY, - "Duplicate ASYNCHRONOUS attribute specified at %L", + if (!gfc_notify_std (GFC_STD_LEGACY, + "Duplicate ASYNCHRONOUS attribute specified at %L", where)) return false; @@ -1814,10 +1814,10 @@ gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where, gfc_error_now ("Duplicate BIND attribute specified at %L", where); else attr->is_bind_c = 1; - + if (where == NULL) where = &gfc_current_locus; - + if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where)) return false; @@ -1970,7 +1970,7 @@ bool gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) { int is_proc_lang_bind_spec; - + /* In line with the other attributes, we only add bits but do not remove them; cf. also PR 41034. */ dest->ext_attr |= src->ext_attr; @@ -2081,7 +2081,7 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) dest->is_c_interop = 1; if (src->is_iso_c) dest->is_iso_c = 1; - + if (src->external && !gfc_add_external (dest, where)) goto fail; if (src->intrinsic && !gfc_add_intrinsic (dest, where)) @@ -2341,7 +2341,7 @@ find_union_component (gfc_symbol *un, const char *name, not found or the components are private. If noaccess is set, no access 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. @@ -2530,7 +2530,7 @@ free_st_labels (gfc_st_label *label) free_st_labels (label->left); free_st_labels (label->right); - + if (label->format != NULL) gfc_free_expr (label->format); free (label); @@ -3022,7 +3022,7 @@ gfc_new_symbol (const char *name, gfc_namespace *ns) p->f2k_derived = NULL; p->assoc = NULL; p->fn_result_spec = 0; - + return p; } @@ -3379,7 +3379,7 @@ find_common_symtree (gfc_symtree *st, gfc_common_head *head) return st; result = find_common_symtree (st->left, head); - if (!result) + if (!result) result = find_common_symtree (st->right, head); return result; @@ -3403,7 +3403,7 @@ gfc_new_undo_checkpoint (gfc_undo_change_set &chg_syms) /* Restore previous state of symbol. Just copy simple stuff. */ - + static void restore_old_symbol (gfc_symbol *p) { @@ -3645,10 +3645,10 @@ free_old_symbol (gfc_symbol *sym) if (sym->old_symbol == NULL) return; - if (sym->old_symbol->as != sym->as) + if (sym->old_symbol->as != sym->as) gfc_free_array_spec (sym->old_symbol->as); - if (sym->old_symbol->value != sym->value) + if (sym->old_symbol->value != sym->value) gfc_free_expr (sym->old_symbol->value); if (sym->old_symbol->formal != sym->formal) @@ -3741,7 +3741,7 @@ free_common_tree (gfc_symtree * common_tree) free_common_tree (common_tree->right); free (common_tree); -} +} /* Recursive function that deletes an entire tree and all the common @@ -3890,7 +3890,7 @@ gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl) } -/* Free the charlen list from cl to end (end is not freed). +/* Free the charlen list from cl to end (end is not freed). Free the whole list if end is NULL. */ void @@ -4047,7 +4047,7 @@ do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *), gcc_assert ((st_func && !sym_func) || (!st_func && sym_func)); nodes = count_st_nodes (st); st_vec = XALLOCAVEC (gfc_symtree *, nodes); - node_cntr = 0; + node_cntr = 0; fill_st_vector (st, st_vec, node_cntr); if (sym_func) @@ -4265,7 +4265,7 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) gfc_component *curr_comp = NULL; bool is_c_interop = false; bool retval = true; - + if (derived_sym == NULL) gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is " "unexpectedly NULL"); @@ -4274,7 +4274,7 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) so we don't repeat warnings/errors. */ if (derived_sym->ts.is_c_interop) return true; - + /* The derived type must have the BIND attribute to be interoperable J3/04-007, Section 15.2.3. */ if (derived_sym->attr.is_bind_c != 1) @@ -4285,7 +4285,7 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) &(derived_sym->declared_at)); retval = false; } - + curr_comp = derived_sym->components; /* Fortran 2003 allows an empty derived type. C99 appears to disallow an @@ -4310,12 +4310,12 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) /* Initialize the derived type as being C interoperable. If we find an error in the components, this will be set false. */ derived_sym->ts.is_c_interop = 1; - + /* Loop through the list of components to verify that the kind of each is a C interoperable type. */ do { - /* The components cannot be pointers (fortran sense). + /* The components cannot be pointers (fortran sense). J3/04-007, Section 15.2.3, C1505. */ if (curr_comp->attr.pointer != 0) { @@ -4347,10 +4347,10 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) derived_sym->name, &(derived_sym->declared_at)); retval = false; } - + /* BIND(C) derived types must have interoperable components. */ if (curr_comp->ts.type == BT_DERIVED - && curr_comp->ts.u.derived->ts.is_iso_c != 1 + && curr_comp->ts.u.derived->ts.is_iso_c != 1 && curr_comp->ts.u.derived != derived_sym) { /* This should be allowed; the draft says a derived-type can not @@ -4361,9 +4361,9 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) } else { - /* Grab the typespec for the given component and test the kind. */ + /* Grab the typespec for the given component and test the kind. */ is_c_interop = gfc_verify_c_interop (&(curr_comp->ts)); - + if (!is_c_interop) { /* Report warning and continue since not fatal. The @@ -4395,9 +4395,9 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) &(curr_comp->loc)); } } - + curr_comp = curr_comp->next; - } while (curr_comp != NULL); + } while (curr_comp != NULL); /* Make sure we don't have conflicts with the attributes. */ @@ -4422,7 +4422,7 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) it's interoperable. */ if (!retval) derived_sym->ts.is_c_interop = 0; - + return retval; } @@ -4445,7 +4445,7 @@ gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree) tmp_sym->ts.f90_type = BT_VOID; tmp_sym->attr.flavor = FL_PARAMETER; tmp_sym->ts.u.derived = dt_symtree->n.sym; - + /* Set the c_address field of c_null_ptr and c_null_funptr to the value of NULL. */ tmp_sym->value = gfc_get_expr (); @@ -4480,10 +4480,10 @@ add_formal_arg (gfc_formal_arglist **head, (*tail)->next = formal_arg; (*tail) = formal_arg; } - + (*tail)->sym = param_sym; (*tail)->next = NULL; - + return; } @@ -4696,7 +4696,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, switch (s) { -#define NAMED_INTCST(a,b,c,d) case a : +#define NAMED_INTCST(a,b,c,d) case a : #define NAMED_REALCST(a,b,c,d) case a : #define NAMED_CMPXCST(a,b,c,d) case a : #define NAMED_LOGCST(a,b,c) case a : diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a3ccc129d11..ad989fd8ac2 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,15 @@ +2017-09-12 Paul Thomas + + PR fortran/82173 + * gfortran.dg/pdt_4.f03 : Remove the 'is being used before it + is defined' error. + * gfortran.dg/pdt_6.f03 : New test. + * gfortran.dg/pdt_7.f03 : New test. + * gfortran.dg/pdt_8.f03 : New test. + + PR fortran/82168 + * gfortran.dg/pdt_9.f03 : New test. + 2017-09-12 Jakub Jelinek PR target/82112 diff --git a/gcc/testsuite/gfortran.dg/pdt_4.f03 b/gcc/testsuite/gfortran.dg/pdt_4.f03 index ea4ece4b646..f585fae5f1e 100644 --- a/gcc/testsuite/gfortran.dg/pdt_4.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_4.f03 @@ -81,8 +81,8 @@ end module end select deallocate (cz) contains - subroutine foo(arg) ! { dg-error "has no IMPLICIT type" } - type (mytype(4, *)) :: arg ! { dg-error "is being used before it is defined" } + subroutine foo(arg) + type (mytype(4, *)) :: arg ! used to have an invalid "is being used before it is defined" end subroutine subroutine bar(arg) ! { dg-error "cannot have DEFERRED type parameters" } type (thytype(8, :, 4) :: arg diff --git a/gcc/testsuite/gfortran.dg/pdt_6.f03 b/gcc/testsuite/gfortran.dg/pdt_6.f03 new file mode 100644 index 00000000000..0c4bc6d3b80 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_6.f03 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! Fixes of ICE on invalid & accepts invalid +! +! Contributed by Janus Weil +! +implicit none + +type :: param_matrix(c,r) + integer, len :: c,r + real :: m(c,r) +end type + +type real_array(k) + integer, kind :: k + real(kind=k), allocatable :: r(:) +end type + +type(param_matrix(1)) :: m1 ! { dg-error "does not contain enough parameter" } +type(param_matrix(1,2)) :: m2 ! ok +type(param_matrix(1,2,3)) :: m3 ! { dg-error "contains too many parameter" } +type(param_matrix(1,2.5)) :: m4 ! { dg-error "must be of INTEGER type" } + +type(real_array(4)) :: a1 ! ok +type(real_array(5)) :: a2 ! { dg-error "Kind 5 not supported for type REAL" } +end diff --git a/gcc/testsuite/gfortran.dg/pdt_7.f03 b/gcc/testsuite/gfortran.dg/pdt_7.f03 new file mode 100644 index 00000000000..b987771aaa8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_7.f03 @@ -0,0 +1,20 @@ +! { dg-do run } +! +! Rejected valid +! +! ! Contributed by Janus Weil +! +implicit none + +type :: param_matrix(k,c,r) + integer, kind :: k + integer, len :: c,r + real(kind=k) :: m(c,r) +end type + +type(param_matrix(8,3,2)) :: mat +real(kind=mat%k) :: m ! Corrected error: Parameter ‘mat’ at (1) has not been declared or ... + +if (kind(m) .ne. 8) call abort + +end diff --git a/gcc/testsuite/gfortran.dg/pdt_8.f03 b/gcc/testsuite/gfortran.dg/pdt_8.f03 new file mode 100644 index 00000000000..d5e393e5e0c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_8.f03 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! Fixes of "accepts invalid". +! Note that the undeclared parameter 'y' in 't1' was originally in the +! type 't'. It turned out to be convenient to defer the error until the +! type is used in the declaration of 'z'. +! +! Contributed by Janus Weil +! +implicit none +type :: t(i,a,x) ! { dg-error "does not|has neither" } + integer, kind :: k ! { dg-error "does not not appear in the type parameter list" } + integer :: i ! { dg-error "has neither the KIND nor LEN attribute" } + integer, kind :: a(3) ! { dg-error "must be a scalar" } + real, kind :: x ! { dg-error "must be INTEGER" } +end type + +type :: t1(k,y) ! { dg-error "not declared as a component of the type" } + integer, kind :: k +end type + +type(t1(4,4)) :: z +end diff --git a/gcc/testsuite/gfortran.dg/pdt_9.f03 b/gcc/testsuite/gfortran.dg/pdt_9.f03 new file mode 100644 index 00000000000..afa1cddd163 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_9.f03 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! Test the fix for PR82168 in which the declarations for 'a' +! and 'b' threw errors even though they are valid. +! +! Contributed by +! +module mod + implicit none + integer, parameter :: dp = kind (0.0d0) + type, public :: v(z, k) + integer, len :: z + integer, kind :: k = kind(0.0) + real(kind = k) :: e(z) + end type v +end module mod + +program bug + use mod + implicit none + type (v(2)) :: a ! Missing parameter replaced by initializer. + type (v(z=:, k=dp)), allocatable :: b ! Keyword was not working for '*' or ':' +end program bug