diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7154ac3c1efe..75a2b7a4108d 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 e57cfded5407..67e1c5bf314a 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 fe2f43a1e577..041ee0d64598 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 789e81ac9293..155702a0a102 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 3231fb98e2d2..ada38b894c41 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 2ca0ad6f6f05..2ba5c405cf78 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 764766d003fe..68486f86a67d 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 245ab25ac108..cd00f52b5745 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 2f3194a1b94e..35c3bdd2fc0b 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 000000000000..3a12e0e35565 --- /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 000000000000..a8028a227aff --- /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 000000000000..0788e8b3cdcc --- /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 000000000000..3516ae2420a1 --- /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 000000000000..045b68db3dbb --- /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 000000000000..fb0a3d9da00f --- /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 000000000000..69dfdeb26e3d --- /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 15cb6417ca76..5e953286588c 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