From: Paul Thomas Date: Fri, 1 Dec 2017 15:05:55 +0000 (+0000) Subject: re PR fortran/82605 ([PDT] ICE in insert_parameter_exprs, at fortran/decl.c:3154) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=276515e6adb1c74234908d627d4fee3840046d74;p=gcc.git re PR fortran/82605 ([PDT] ICE in insert_parameter_exprs, at fortran/decl.c:3154) 2017-12-01 Paul Thomas PR fortran/82605 * resolve.c (get_pdt_constructor): Initialize 'cons' to NULL. (resolve_pdt): Correct typo in prior comment. Emit an error if any parameters are deferred and the object is neither pointer nor allocatable. PR fortran/82606 * decl.c (gfc_get_pdt_instance): Continue if the parameter sym is not present or has no name. Select the parameter by name of component, rather than component order. Remove all the other manipulations of 'tail' when building the pdt instance. (gfc_match_formal_arglist): Emit and error if a star is picked up in a PDT decl parameter list. PR fortran/82622 * trans-array.c (set_loop_bounds): If a GFC_SS_COMPONENT has an info->end, use it rather than falling through to gcc_unreachable. (structure_alloc_comps): Check that param->name is non-null before comparing with the component name. * trans-decl.c (gfc_get_symbol_decl): Do not use the static initializer for PDT symbols. (gfc_init_default_dt): Do nothing for PDT symbols. * trans-io.c (transfer_array_component): Parameterized array components use the descriptor ubound since the shape is not available. PR fortran/82719 PR fortran/82720 * trans-expr.c (gfc_conv_component_ref): Do not use the charlen backend_decl of pdt strings. Use the hidden component instead. * trans-io.c (transfer_expr): Do not do IO on "hidden" string lengths. Use the hidden string length for pdt string transfers by adding it to the se structure. When finished nullify the se string length. PR fortran/82866 * decl.c (gfc_match_formal_arglist): If a name is not found or star is found, while reading a type parameter list, emit an immediate error. (gfc_match_derived_decl): On reading a PDT parameter list, on failure to match call gfc_error_recovery. PR fortran/82978 * decl.c (build_struct): Character kind defaults to 1, so use kind_expr whatever is the set value. (gfc_get_pdt_instance): Ditto. * trans-array.c (structure_alloc_comps): Copy the expression for the PDT string length before parameter substitution. Use this expression for evaluation and free it after use. 2017-12-01 Paul Thomas PR fortran/82605 * gfortran.dg/pdt_4.f03 : Incorporate the new error. PR fortran/82606 * gfortran.dg/pdt_19.f03 : New test. * gfortran.dg/pdt_21.f03 : New test. PR fortran/82622 * gfortran.dg/pdt_20.f03 : New test. * gfortran.dg/pdt_22.f03 : New test. PR fortran/82719 PR fortran/82720 * gfortran.dg/pdt_23.f03 : New test. PR fortran/82866 * gfortran.dg/pdt_24.f03 : New test. PR fortran/82978 * gfortran.dg/pdt_10.f03 : Correct for error in coding the for kind 4 component and change the kind check appropriately. * gfortran.dg/pdt_25.f03 : New test. From-SVN: r255311 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7154ac3c1ef..75a2b7a4108 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,56 @@ +2017-12-01 Paul Thomas + + PR fortran/82605 + * resolve.c (get_pdt_constructor): Initialize 'cons' to NULL. + (resolve_pdt): Correct typo in prior comment. Emit an error if + any parameters are deferred and the object is neither pointer + nor allocatable. + + PR fortran/82606 + * decl.c (gfc_get_pdt_instance): Continue if the parameter sym + is not present or has no name. Select the parameter by name + of component, rather than component order. Remove all the other + manipulations of 'tail' when building the pdt instance. + (gfc_match_formal_arglist): Emit and error if a star is picked + up in a PDT decl parameter list. + + PR fortran/82622 + * trans-array.c (set_loop_bounds): If a GFC_SS_COMPONENT has an + info->end, use it rather than falling through to + gcc_unreachable. + (structure_alloc_comps): Check that param->name is non-null + before comparing with the component name. + * trans-decl.c (gfc_get_symbol_decl): Do not use the static + initializer for PDT symbols. + (gfc_init_default_dt): Do nothing for PDT symbols. + * trans-io.c (transfer_array_component): Parameterized array + components use the descriptor ubound since the shape is not + available. + + PR fortran/82719 + PR fortran/82720 + * trans-expr.c (gfc_conv_component_ref): Do not use the charlen + backend_decl of pdt strings. Use the hidden component instead. + * trans-io.c (transfer_expr): Do not do IO on "hidden" string + lengths. Use the hidden string length for pdt string transfers + by adding it to the se structure. When finished nullify the + se string length. + + PR fortran/82866 + * decl.c (gfc_match_formal_arglist): If a name is not found or + star is found, while reading a type parameter list, emit an + immediate error. + (gfc_match_derived_decl): On reading a PDT parameter list, on + failure to match call gfc_error_recovery. + + PR fortran/82978 + * decl.c (build_struct): Character kind defaults to 1, so use + kind_expr whatever is the set value. + (gfc_get_pdt_instance): Ditto. + * trans-array.c (structure_alloc_comps): Copy the expression + for the PDT string length before parameter substitution. Use + this expression for evaluation and free it after use. + 2017-12-01 Jakub Jelinek PR c/79153 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index e57cfded540..67e1c5bf314 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1971,7 +1971,8 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, c->ts.u.cl = cl; if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED - && c->ts.kind == 0 && saved_kind_expr != NULL) + && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER) + && saved_kind_expr != NULL) c->kind_expr = gfc_copy_expr (saved_kind_expr); c->attr = current_attr; @@ -3250,6 +3251,9 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, name_seen = true; param = type_param_name_list->sym; + if (!param || !param->name) + continue; + c1 = gfc_find_component (pdt, param->name, false, true, NULL); /* An error should already have been thrown in resolve.c (resolve_fl_derived0). */ @@ -3406,9 +3410,19 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, for (; c1; c1 = c1->next) { gfc_add_component (instance, c1->name, &c2); + c2->ts = c1->ts; c2->attr = c1->attr; + /* The order of declaration of the type_specs might not be the + same as that of the components. */ + if (c1->attr.pdt_kind || c1->attr.pdt_len) + { + for (tail = type_param_spec_list; tail; tail = tail->next) + if (strcmp (c1->name, tail->name) == 0) + break; + } + /* Deal with type extension by recursively calling this function to obtain the instance of the extended type. */ if (gfc_current_state () != COMP_DERIVED @@ -3453,17 +3467,12 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, } instance->attr.extension = c2->ts.u.derived->attr.extension + 1; - /* Advance the position in the spec list by the number of - parameters in the extended type. */ - tail = type_param_spec_list; - for (f = c1->ts.u.derived->formal; f && f->next; f = f->next) - tail = tail->next; - continue; } /* Set the component kind using the parameterized expression. */ - if (c1->ts.kind == 0 && c1->kind_expr != NULL) + if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER) + && c1->kind_expr != NULL) { gfc_expr *e = gfc_copy_expr (c1->kind_expr); gfc_insert_kind_parameter_exprs (e); @@ -3509,8 +3518,6 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, if (!c2->initializer && c1->initializer) c2->initializer = gfc_copy_expr (c1->initializer); - - tail = tail->next; } /* Copy the array spec. */ @@ -5944,18 +5951,24 @@ gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, if (gfc_match_char ('*') == MATCH_YES) { sym = NULL; - if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument " - "at %C")) + if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS, + "Alternate-return argument at %C")) { m = MATCH_ERROR; goto cleanup; } + else if (typeparam) + gfc_error_now ("A parameter name is required at %C"); } else { m = gfc_match_name (name); if (m != MATCH_YES) - goto cleanup; + { + if(typeparam) + gfc_error_now ("A parameter name is required at %C"); + goto cleanup; + } if (!typeparam && gfc_get_symbol (name, NULL, &sym)) goto cleanup; @@ -9828,9 +9841,11 @@ gfc_match_derived_decl (void) if (parameterized_type) { - /* Ignore error or mismatches to avoid the component declarations - causing problems later. */ - gfc_match_formal_arglist (sym, 0, 0, true); + /* Ignore error or mismatches by going to the end of the statement + in order to avoid the component declarations causing problems. */ + m = gfc_match_formal_arglist (sym, 0, 0, true); + if (m != MATCH_YES) + gfc_error_recovery (); m = gfc_match_eos (); if (m != MATCH_YES) return m; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index fe2f43a1e57..041ee0d6459 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1174,7 +1174,7 @@ static bool get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr, gfc_symbol *derived) { - gfc_constructor *cons; + gfc_constructor *cons = NULL; gfc_component *comp; bool t = true; @@ -14010,6 +14010,8 @@ resolve_fl_derived0 (gfc_symbol *sym) { for (f = sym->formal; f; f = f->next) { + if (!f->sym) + continue; c = gfc_find_component (sym, f->sym->name, true, true, NULL); if (c == NULL) { @@ -14283,7 +14285,7 @@ resolve_fl_parameter (gfc_symbol *sym) } -/* Called by resolve_symbol to chack PDTs. */ +/* Called by resolve_symbol to check PDTs. */ static void resolve_pdt (gfc_symbol* sym) @@ -14293,11 +14295,18 @@ resolve_pdt (gfc_symbol* sym) gfc_component *c; bool const_len_exprs = true; bool assumed_len_exprs = false; + symbol_attribute *attr; if (sym->ts.type == BT_DERIVED) - derived = sym->ts.u.derived; + { + derived = sym->ts.u.derived; + attr = &(sym->attr); + } else if (sym->ts.type == BT_CLASS) - derived = CLASS_DATA (sym)->ts.u.derived; + { + derived = CLASS_DATA (sym)->ts.u.derived; + attr = &(CLASS_DATA (sym)->attr); + } else gcc_unreachable (); @@ -14315,6 +14324,14 @@ resolve_pdt (gfc_symbol* sym) const_len_exprs = false; else if (param->spec_type == SPEC_ASSUMED) assumed_len_exprs = true; + + if (param->spec_type == SPEC_DEFERRED + && !attr->allocatable && !attr->pointer) + gfc_error ("The object %qs at %L has a deferred LEN " + "parameter %qs and is neither allocatable " + "nor a pointer", sym->name, &sym->declared_at, + param->name); + } if (!const_len_exprs diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 789e81ac929..155702a0a10 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5043,6 +5043,17 @@ set_loop_bounds (gfc_loopinfo *loop) break; } + case GFC_SS_COMPONENT: + { + if (info->end[dim] != NULL_TREE) + { + loop->to[n] = info->end[dim]; + break; + } + else + gcc_unreachable (); + } + default: gcc_unreachable (); } @@ -8975,7 +8986,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_actual_arglist *param = pdt_param_list; gfc_init_se (&tse, NULL); for (; param; param = param->next) - if (!strcmp (c->name, param->name)) + if (param->name && !strcmp (c->name, param->name)) c_expr = param->expr; if (!c_expr) @@ -8992,14 +9003,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, { gfc_se tse; gfc_init_se (&tse, NULL); - tree strlen; + tree strlen = NULL_TREE; + gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length); /* Convert the parameterized string length to its value. The string length is stored in a hidden field in the same way as deferred string lengths. */ - gfc_insert_parameter_exprs (c->ts.u.cl->length, pdt_param_list); + gfc_insert_parameter_exprs (e, pdt_param_list); if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE) { - gfc_conv_expr_type (&tse, c->ts.u.cl->length, + gfc_conv_expr_type (&tse, e, TREE_TYPE (strlen)); strlen = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (strlen), @@ -9007,6 +9019,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_add_modify (&fnblock, strlen, tse.expr); c->ts.u.cl->backend_decl = strlen; } + gfc_free_expr (e); + /* Scalar parameterizied strings can be allocated now. */ if (!c->as) { diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 3231fb98e2d..ada38b894c4 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1809,7 +1809,10 @@ gfc_get_symbol_decl (gfc_symbol * sym) || !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE) && (flag_coarray != GFC_FCOARRAY_LIB - || !sym->attr.codimension || sym->attr.allocatable)) + || !sym->attr.codimension || sym->attr.allocatable) + && !(sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) + && !(sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)) { /* Add static initializer. For procedures, it is only needed if SAVE is specified otherwise they need to be reinitialized @@ -4004,6 +4007,10 @@ gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) gcc_assert (block); + /* Initialization of PDTs is done elsewhere. */ + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) + return; + gcc_assert (!sym->attr.allocatable); gfc_set_sym_referenced (sym); e = gfc_lval_expr_from_sym (sym); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 2ca0ad6f6f0..2ba5c405cf7 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2401,7 +2401,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) /* Allocatable deferred char arrays are to be handled by the gfc_deferred_ strlen () conditional below. */ if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer - && !(c->attr.allocatable && c->ts.deferred)) + && !(c->attr.allocatable && c->ts.deferred) + && !c->attr.pdt_string) { tmp = c->ts.u.cl->backend_decl; /* Components must always be constant length. */ diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 764766d003f..68486f86a67 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -2146,7 +2146,12 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where) ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank, GFC_SS_COMPONENT); ss_array = &ss->info->data.array; - ss_array->shape = gfc_get_shape (cm->as->rank); + + if (cm->attr.pdt_array) + ss_array->shape = NULL; + else + ss_array->shape = gfc_get_shape (cm->as->rank); + ss_array->descriptor = expr; ss_array->data = gfc_conv_array_data (expr); ss_array->offset = gfc_conv_array_offset (expr); @@ -2155,10 +2160,15 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where) ss_array->start[n] = gfc_conv_array_lbound (expr, n); ss_array->stride[n] = gfc_index_one_node; - mpz_init (ss_array->shape[n]); - mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer, - cm->as->lower[n]->value.integer); - mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1); + if (cm->attr.pdt_array) + ss_array->end[n] = gfc_conv_array_ubound (expr, n); + else + { + mpz_init (ss_array->shape[n]); + mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer, + cm->as->lower[n]->value.integer); + mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1); + } } /* Once we got ss, we use scalarizer to create the loop. */ @@ -2193,8 +2203,11 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where) gfc_add_block_to_block (&block, &loop.pre); gfc_add_block_to_block (&block, &loop.post); - gcc_assert (ss_array->shape != NULL); - gfc_free_shape (&ss_array->shape, cm->as->rank); + if (!cm->attr.pdt_array) + { + gcc_assert (ss_array->shape != NULL); + gfc_free_shape (&ss_array->shape, cm->as->rank); + } gfc_cleanup_loop (&loop); return gfc_finish_block (&block); @@ -2452,6 +2465,10 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, for (c = ts->u.derived->components; c; c = c->next) { + /* Ignore hidden string lengths. */ + if (c->name[0] == '_') + continue; + field = c->backend_decl; gcc_assert (field && TREE_CODE (field) == FIELD_DECL); @@ -2466,9 +2483,29 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, } else { - if (!c->attr.pointer) + tree strlen = NULL_TREE; + + if (!c->attr.pointer && !c->attr.pdt_string) tmp = gfc_build_addr_expr (NULL_TREE, tmp); + + /* Use the hidden string length for pdt strings. */ + if (c->attr.pdt_string + && gfc_deferred_strlen (c, &strlen) + && strlen != NULL_TREE) + { + strlen = fold_build3_loc (UNKNOWN_LOCATION, + COMPONENT_REF, + TREE_TYPE (strlen), + expr, strlen, NULL_TREE); + se->string_length = strlen; + } + transfer_expr (se, &c->ts, tmp, code, NULL_TREE); + + /* Reset so that the pdt string length does not propagate + through to other strings. */ + if (c->attr.pdt_string && strlen) + se->string_length = NULL_TREE; } } return; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 245ab25ac10..cd00f52b574 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,28 @@ +2017-12-01 Paul Thomas + + PR fortran/82605 + * gfortran.dg/pdt_4.f03 : Incorporate the new error. + + PR fortran/82606 + * gfortran.dg/pdt_19.f03 : New test. + * gfortran.dg/pdt_21.f03 : New test. + + PR fortran/82622 + * gfortran.dg/pdt_20.f03 : New test. + * gfortran.dg/pdt_22.f03 : New test. + + PR fortran/82719 + PR fortran/82720 + * gfortran.dg/pdt_23.f03 : New test. + + PR fortran/82866 + * gfortran.dg/pdt_24.f03 : New test. + + PR fortran/82978 + * gfortran.dg/pdt_10.f03 : Correct for error in coding the for + kind 4 component and change the kind check appropriately. + * gfortran.dg/pdt_25.f03 : New test. + 2017-12-01 Richard Biener PR tree-optimization/83232 diff --git a/gcc/testsuite/gfortran.dg/pdt_10.f03 b/gcc/testsuite/gfortran.dg/pdt_10.f03 index 2f3194a1b94..35c3bdd2fc0 100644 --- a/gcc/testsuite/gfortran.dg/pdt_10.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_10.f03 @@ -10,6 +10,7 @@ program p use, intrinsic :: iso_fortran_env, only : CK => character_kinds implicit none character(kind = 4), parameter :: c = 'a' + character(kind = 4), parameter :: hello = "Hello World!" type :: pdt_t(k,l) integer, kind :: k = CK(1) integer, len :: l @@ -23,8 +24,8 @@ program p if (KIND (foo%s) .ne. 1) call abort if (len (foo%s) .ne. 12) call abort - foo_4%s = "Hello World!" - if (foo_4%s .ne. "Hello World!") call abort - if (KIND (foo_4%s) .ne. 1) call abort + foo_4%s = hello + if (foo_4%s .ne. hello) call abort + if (KIND (foo_4%s) .ne. 4) call abort if (len (foo_4%s) .ne. 12) call abort end program diff --git a/gcc/testsuite/gfortran.dg/pdt_19.f03 b/gcc/testsuite/gfortran.dg/pdt_19.f03 new file mode 100644 index 00000000000..3a12e0e3556 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_19.f03 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! Tests the fix for PR82606. +! +! Contributed by Gerhard Steinmetz +! +program p + type t(a, b) + integer, len :: b ! Note different order of component declarations + integer, kind :: a ! compared with the type_spec_list order. + real(a) :: r(b) + end type + type(t(8, :)), allocatable :: x + real(x%a) :: y ! Used to die here because initializers were mixed up. + allocate(t(8, 2) :: x) + if (kind(y) .ne. x%a) call abort + deallocate(x) +end diff --git a/gcc/testsuite/gfortran.dg/pdt_20.f03 b/gcc/testsuite/gfortran.dg/pdt_20.f03 new file mode 100644 index 00000000000..a8028a227af --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_20.f03 @@ -0,0 +1,20 @@ +! { dg-do run } +! +! Tests the fix for PR82622. +! +! Contributed by Gerhard Steinmetz +! +program p + type t(a) + integer, len :: a + end type + type t2(b) + integer, len :: b + type(t(1)) :: r(b) + end type + type(t2(:)), allocatable :: x + allocate (t2(3) :: x) ! Used to segfault in trans-array.c. + if (x%b .ne. 3) call abort + if (x%b .ne. size (x%r, 1)) call abort + if (any (x%r%a .ne. 1)) call abort +end diff --git a/gcc/testsuite/gfortran.dg/pdt_21.f03 b/gcc/testsuite/gfortran.dg/pdt_21.f03 new file mode 100644 index 00000000000..0788e8b3cdc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_21.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! Tests the fix for PR82606 comment #1. +! +! Contributed by Gerhard Steinmetz +! +program p + type t(a, b, *) ! { dg-error "A parameter name is required" } + integer, kind :: a + integer, len :: b + real(a) :: r(b) + end type + type(t(8, 3)) :: x + real(x%a) :: y +end diff --git a/gcc/testsuite/gfortran.dg/pdt_22.f03 b/gcc/testsuite/gfortran.dg/pdt_22.f03 new file mode 100644 index 00000000000..3516ae2420a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_22.f03 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! Tests the fix for PR82622 comment #1, where the declaration of +! 'x' choked during initialization. Once fixed, it was found that +! IO was not working correctly for PDT array components. +! +! Contributed by Gerhard Steinmetz +! +program p + character(120) :: buffer + integer :: i(4) + type t(a) + integer, len :: a + end type + type t2(b) + integer, len :: b + type(t(1)) :: r(b) + end type + type(t2(3)) :: x + write (buffer,*) x + read (buffer,*) i + if (any (i .ne. [3,1,1,1])) call abort +end diff --git a/gcc/testsuite/gfortran.dg/pdt_23.f03 b/gcc/testsuite/gfortran.dg/pdt_23.f03 new file mode 100644 index 00000000000..045b68db3db --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_23.f03 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! Tests the fixes for PR82719 and PR82720. +! +! Contributed by Gerhard Steinmetz +! +program p + character(120) :: buffer + character(3) :: chr + integer :: i + type t(a) + integer, len :: a + character(len=a) :: c + end type + type(t(:)), allocatable :: x + allocate (t(2) :: x) + + x = t(2,'ab') + write (buffer, *) x%c ! Tests the fix for PR82720 + read (buffer, *) chr + if (trim (chr) .ne. 'ab') call abort + + x = t(3,'xyz') + if (len (x%c) .ne. 3) call abort + write (buffer, *) x ! Tests the fix for PR82719 + read (buffer, *) i, chr + if (i .ne. 3) call abort + if (chr .ne. 'xyz') call abort + + buffer = " 3 lmn" + read (buffer, *) x ! Some thought will be needed for PDT reads. + if (x%c .ne. 'lmn') call abort +end diff --git a/gcc/testsuite/gfortran.dg/pdt_24.f03 b/gcc/testsuite/gfortran.dg/pdt_24.f03 new file mode 100644 index 00000000000..fb0a3d9da00 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_24.f03 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! Tests the fixes for PR82866. +! +! Contributed by Gerhard Steinmetz +! +module s + type t(*, a, :) ! { dg-error "A parameter name is required" } + integer, len :: a + end type +end diff --git a/gcc/testsuite/gfortran.dg/pdt_25.f03 b/gcc/testsuite/gfortran.dg/pdt_25.f03 new file mode 100644 index 00000000000..69dfdeb26e3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_25.f03 @@ -0,0 +1,43 @@ +! {dg-do run } +! +! Tests the fix for PR82978 in which all the parameterized string +! lengths with the same value of parameter 'k' had the same value +! regardless of the value of 'l'. In this testcase, the length for +! 'l' = 5 was taken. +! +! Contributed by Fritz Reese +! + implicit none + + type :: pdt_t(k, l) + integer, kind :: k + integer, len :: l + character(kind=k,len=l) :: chr + integer :: i(l) + end type + + type(pdt_t(1, 4)) :: x1 + type(pdt_t(1, 5)) :: x2 + type(pdt_t(4, 5)) :: x3 + + call test (x1, 4) + call test (x2, 5) + +! Kind tests appear because of problem identified in comment #! +! due to Dominque d'Humieres + + if (kind (x2%chr) .ne. 1) call abort + if (kind (x3%chr) .ne. 4) call abort + +contains + + subroutine test (x, i) + type(pdt_t(1, *)) :: x + integer :: i + + if (x%l .ne. i) call abort + if (len(x%chr) .ne. i) call abort + if (size(x%i,1) .ne. i) call abort + end subroutine + +end diff --git a/gcc/testsuite/gfortran.dg/pdt_4.f03 b/gcc/testsuite/gfortran.dg/pdt_4.f03 index 15cb6417ca7..5e953286588 100644 --- a/gcc/testsuite/gfortran.dg/pdt_4.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_4.f03 @@ -96,7 +96,10 @@ contains subroutine foo(arg) type (mytype(4, *)) :: arg ! OK end subroutine - subroutine bar(arg) ! OK + subroutine bar(arg) ! { dg-error "is neither allocatable nor a pointer" } type (thytype(8, :, 4) :: arg end subroutine + subroutine foobar(arg) ! OK + type (thytype(8, *, 4) :: arg + end subroutine end