git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/82605 ([PDT] ICE in insert_parameter_exprs, at fortran/decl.c:3154) 

2017-12-01  Paul Thomas  <pault@gcc.gnu.org>

	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  <pault@gcc.gnu.org>

	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
This commit is contained in:
Paul Thomas 2017-12-01 15:05:55 +00:00
parent ebdc83f0a8
commit 276515e6ad
17 changed files with 374 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
gcc/fortran/ChangeLog
View File

@ -1,3 +1,56 @@
2017-12-01 Paul Thomas <pault@gcc.gnu.org>
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 <jakub@redhat.com>
PR c/79153

47
gcc/fortran/decl.c
View File

@ -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;

25
gcc/fortran/resolve.c
View File

@ -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

22
gcc/fortran/trans-array.c
View File

@ -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)
{

9
gcc/fortran/trans-decl.c
View File

@ -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);

3
gcc/fortran/trans-expr.c
View File

@ -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. */

53
gcc/fortran/trans-io.c
View File

@ -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;

25
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,28 @@
2017-12-01 Paul Thomas <pault@gcc.gnu.org>
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 <rguenther@suse.de>
PR tree-optimization/83232

7
gcc/testsuite/gfortran.dg/pdt_10.f03
View File

@ -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

18
gcc/testsuite/gfortran.dg/pdt_19.f03 Normal file
View File

@ -0,0 +1,18 @@
! { dg-do compile }
!
! Tests the fix for PR82606.
!
! Contributed by Gerhard Steinmetz <gscfq@t-online.de>
!
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

20
gcc/testsuite/gfortran.dg/pdt_20.f03 Normal file
View File

@ -0,0 +1,20 @@
! { dg-do run }
!
! Tests the fix for PR82622.
!
! Contributed by Gerhard Steinmetz <gscfq@t-online.de>
!
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

15
gcc/testsuite/gfortran.dg/pdt_21.f03 Normal file
View File

@ -0,0 +1,15 @@
! { dg-do compile }
!
! Tests the fix for PR82606 comment #1.
!
! Contributed by Gerhard Steinmetz <gscfq@t-online.de>
!
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

23
gcc/testsuite/gfortran.dg/pdt_22.f03 Normal file
View File

@ -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 <gscfq@t-online.de>
!
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

33
gcc/testsuite/gfortran.dg/pdt_23.f03 Normal file
View File

@ -0,0 +1,33 @@
! { dg-do run }
!
! Tests the fixes for PR82719 and PR82720.
!
! Contributed by Gerhard Steinmetz <gscfq@t-online.de>
!
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

11
gcc/testsuite/gfortran.dg/pdt_24.f03 Normal file
View File

@ -0,0 +1,11 @@
! { dg-do compile }
!
! Tests the fixes for PR82866.
!
! Contributed by Gerhard Steinmetz <gscfq@t-online.de>
!
module s
type t(*, a, :) ! { dg-error "A parameter name is required" }
integer, len :: a
end type
end

43
gcc/testsuite/gfortran.dg/pdt_25.f03 Normal file
View File

@ -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 <foreese@gcc.gnu.org>
!
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 <dominiq@lps.ens.fr>
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

5
gcc/testsuite/gfortran.dg/pdt_4.f03
View File

@ -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