This patch fixes the above PRs and the additional problems in comment
#1 of both 82606 and 82622.
For the main part, the patch consists of 'obvious' tweaks to the PDT
machinery. The exception to this is the chunk in
trans-array.c(set_loop_bounds), which is needed to handle
parameterized array components coming from trans-io.c. This is safe
because the code would have fallen through to gcc_unreachable
otherwise. If the info->end is present then this can be used.
Bootstrapped and regtested on FC23/x86_64 - OK for trunk?
I will commit tomorrow morning if there are no complaints in the meantime.
Regards
Paul
2017-11-30 Paul Thomas <pa...@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.
2017-11-30 Paul Thomas <pa...@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.
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 255249)
--- gcc/fortran/decl.c (working copy)
*************** gfc_get_pdt_instance (gfc_actual_arglist
*** 3250,3255 ****
--- 3250,3258 ----
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). */
*************** gfc_get_pdt_instance (gfc_actual_arglist
*** 3406,3414 ****
--- 3409,3427 ----
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
*************** gfc_get_pdt_instance (gfc_actual_arglist
*** 3453,3464 ****
}
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;
}
--- 3466,3471 ----
*************** gfc_get_pdt_instance (gfc_actual_arglist
*** 3509,3516 ****
if (!c2->initializer && c1->initializer)
c2->initializer = gfc_copy_expr (c1->initializer);
-
- tail = tail->next;
}
/* Copy the array spec. */
--- 3516,3521 ----
*************** gfc_match_formal_arglist (gfc_symbol *pr
*** 5944,5955 ****
if (gfc_match_char ('*') == MATCH_YES)
{
sym = NULL;
! if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
! "at %C"))
{
m = MATCH_ERROR;
goto cleanup;
}
}
else
{
--- 5949,5962 ----
if (gfc_match_char ('*') == MATCH_YES)
{
sym = NULL;
! 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
{
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 255249)
--- gcc/fortran/resolve.c (working copy)
*************** static bool
*** 1174,1180 ****
get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
gfc_symbol *derived)
{
! gfc_constructor *cons;
gfc_component *comp;
bool t = true;
--- 1174,1180 ----
get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
gfc_symbol *derived)
{
! gfc_constructor *cons = NULL;
gfc_component *comp;
bool t = true;
*************** resolve_fl_derived0 (gfc_symbol *sym)
*** 14010,14015 ****
--- 14010,14017 ----
{
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)
{
*************** resolve_fl_parameter (gfc_symbol *sym)
*** 14283,14289 ****
}
! /* Called by resolve_symbol to chack PDTs. */
static void
resolve_pdt (gfc_symbol* sym)
--- 14285,14291 ----
}
! /* Called by resolve_symbol to check PDTs. */
static void
resolve_pdt (gfc_symbol* sym)
*************** resolve_pdt (gfc_symbol* sym)
*** 14293,14303 ****
gfc_component *c;
bool const_len_exprs = true;
bool assumed_len_exprs = false;
if (sym->ts.type == BT_DERIVED)
! derived = sym->ts.u.derived;
else if (sym->ts.type == BT_CLASS)
! derived = CLASS_DATA (sym)->ts.u.derived;
else
gcc_unreachable ();
--- 14295,14312 ----
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;
! attr = &(sym->attr);
! }
else if (sym->ts.type == BT_CLASS)
! {
! derived = CLASS_DATA (sym)->ts.u.derived;
! attr = &(CLASS_DATA (sym)->attr);
! }
else
gcc_unreachable ();
*************** resolve_pdt (gfc_symbol* sym)
*** 14315,14320 ****
--- 14324,14337 ----
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
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 255249)
--- gcc/fortran/trans-array.c (working copy)
*************** set_loop_bounds (gfc_loopinfo *loop)
*** 5043,5048 ****
--- 5043,5059 ----
break;
}
+ case GFC_SS_COMPONENT:
+ {
+ if (info->end[dim] != NULL_TREE)
+ {
+ loop->to[n] = info->end[dim];
+ break;
+ }
+ else
+ gcc_unreachable ();
+ }
+
default:
gcc_unreachable ();
}
*************** structure_alloc_comps (gfc_symbol * der_
*** 8975,8981 ****
gfc_actual_arglist *param = pdt_param_list;
gfc_init_se (&tse, NULL);
for (; param; param = param->next)
! if (!strcmp (c->name, param->name))
c_expr = param->expr;
if (!c_expr)
--- 8986,8992 ----
gfc_actual_arglist *param = pdt_param_list;
gfc_init_se (&tse, NULL);
for (; param; param = param->next)
! if (param->name && !strcmp (c->name, param->name))
c_expr = param->expr;
if (!c_expr)
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 255249)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1809,1815 ****
|| !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))
{
/* Add static initializer. For procedures, it is only needed if
SAVE is specified otherwise they need to be reinitialized
--- 1809,1818 ----
|| !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->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
*************** gfc_init_default_dt (gfc_symbol * sym, s
*** 4004,4009 ****
--- 4007,4016 ----
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);
Index: gcc/fortran/trans-io.c
===================================================================
*** gcc/fortran/trans-io.c (revision 255249)
--- gcc/fortran/trans-io.c (working copy)
*************** transfer_array_component (tree expr, gfc
*** 2146,2152 ****
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);
ss_array->descriptor = expr;
ss_array->data = gfc_conv_array_data (expr);
ss_array->offset = gfc_conv_array_offset (expr);
--- 2146,2157 ----
ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
GFC_SS_COMPONENT);
ss_array = &ss->info->data.array;
!
! 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);
*************** transfer_array_component (tree expr, gfc
*** 2155,2164 ****
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);
}
/* Once we got ss, we use scalarizer to create the loop. */
--- 2160,2174 ----
ss_array->start[n] = gfc_conv_array_lbound (expr, n);
ss_array->stride[n] = gfc_index_one_node;
! 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. */
*************** transfer_array_component (tree expr, gfc
*** 2193,2200 ****
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);
gfc_cleanup_loop (&loop);
return gfc_finish_block (&block);
--- 2203,2213 ----
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
! 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);
Index: gcc/testsuite/gfortran.dg/pdt_19.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_19.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_19.f03 (working copy)
***************
*** 0 ****
--- 1,18 ----
+ ! { dg-do compile }
+ !
+ ! Tests the fix for PR82606.
+ !
+ ! Contributed by Gerhard Steinmetz <gs...@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
Index: gcc/testsuite/gfortran.dg/pdt_20.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_20.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_20.f03 (working copy)
***************
*** 0 ****
--- 1,20 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR82622.
+ !
+ ! Contributed by Gerhard Steinmetz <gs...@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
Index: gcc/testsuite/gfortran.dg/pdt_21.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_21.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_21.f03 (working copy)
***************
*** 0 ****
--- 1,15 ----
+ ! { dg-do compile }
+ !
+ ! Tests the fix for PR82606 comment #1.
+ !
+ ! Contributed by Gerhard Steinmetz <gs...@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
Index: gcc/testsuite/gfortran.dg/pdt_22.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_22.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_22.f03 (working copy)
***************
*** 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 <gs...@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
Index: gcc/testsuite/gfortran.dg/pdt_4.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_4.f03 (revision 255249)
--- gcc/testsuite/gfortran.dg/pdt_4.f03 (working copy)
*************** contains
*** 96,102 ****
subroutine foo(arg)
type (mytype(4, *)) :: arg ! OK
end subroutine
! subroutine bar(arg) ! OK
type (thytype(8, :, 4) :: arg
end subroutine
end
--- 96,105 ----
subroutine foo(arg)
type (mytype(4, *)) :: arg ! OK
end subroutine
! 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
