Dear Thomas, dear All,
I have fixed all the PDT bugs that have been reported to me so far in
the attached patch. The patch is straightforward and is commented for
clarity where necessary. Please note that whitespace changes have been
suppressed. For this reason, if you are tempted to try the patch use
the -l option when you apply it.
Bootstrapped and regtested on FC23/x86_64 - OK for trunk?
Since I really want to get on with other things, if I do not receive
any contrary comments I will commit tomorrow night.
Cheers
Paul
2017-09-11 Paul Thomas <[email protected]>
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-11 Paul Thomas <[email protected]>
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.
--
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 251948)
--- gcc/fortran/decl.c (working copy)
*************** variable_decl (int elem)
*** 2537,2542 ****
--- 2537,2575 ----
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. */
*************** gfc_get_pdt_instance (gfc_actual_arglist
*** 3193,3200 ****
{
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;
}
}
--- 3226,3232 ----
{
gfc_error ("The type parameter spec list at %C cannot contain "
"both ASSUMED and DEFERRED parameters");
! goto error_return;
}
}
*************** gfc_get_pdt_instance (gfc_actual_arglist
*** 3202,3211 ****
name_seen = true;
param = type_param_name_list->sym;
kind_expr = NULL;
if (!name_seen)
{
! if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
kind_expr = gfc_copy_expr (actual_param->expr);
}
else
--- 3234,3260 ----
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 && !(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
*************** gfc_get_pdt_instance (gfc_actual_arglist
*** 3225,3231 ****
{
gfc_error ("The derived parameter '%qs' at %C does not "
"have a default value", param->name);
! return MATCH_ERROR;
}
}
}
--- 3274,3280 ----
{
gfc_error ("The derived parameter '%qs' at %C does not "
"have a default value", param->name);
! goto error_return;
}
}
}
*************** gfc_get_pdt_instance (gfc_actual_arglist
*** 3247,3252 ****
--- 3296,3312 ----
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);
*************** gfc_get_pdt_instance (gfc_actual_arglist
*** 3257,3263 ****
if (!param->attr.pdt_kind)
{
! if (!name_seen)
actual_param = actual_param->next;
if (kind_expr)
{
--- 3317,3323 ----
if (!param->attr.pdt_kind)
{
! if (!name_seen && actual_param)
actual_param = actual_param->next;
if (kind_expr)
{
*************** gfc_get_pdt_instance (gfc_actual_arglist
*** 3273,3288 ****
{
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;
}
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;
}
gfc_extract_int (kind_expr, &kind_value);
--- 3333,3346 ----
{
gfc_error ("The KIND parameter '%qs' at %C cannot either be "
"ASSUMED or DEFERRED", param->name);
! 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);
! goto error_return;
}
gfc_extract_int (kind_expr, &kind_value);
*************** gfc_get_pdt_instance (gfc_actual_arglist
*** 3293,3304 ****
gfc_free_expr (kind_expr);
}
/* 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;
}
m = MATCH_YES;
--- 3351,3369 ----
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");
! goto error_return;
}
m = MATCH_YES;
*************** gfc_get_pdt_instance (gfc_actual_arglist
*** 3370,3376 ****
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;
}
instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
--- 3435,3441 ----
gfc_error ("Maximum extension level reached with type %qs at %L",
c2->ts.u.derived->name,
&c2->ts.u.derived->declared_at);
! goto error_return;
}
instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
*************** gfc_get_pdt_instance (gfc_actual_arglist
*** 3390,3395 ****
--- 3455,3466 ----
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. */
*************** gfc_get_pdt_instance (gfc_actual_arglist
*** 3499,3504 ****
--- 3570,3579 ----
*ext_param_list = type_param_spec_list;
*sym = instance;
return m;
+
+ error_return:
+ gfc_free_actual_arglist (type_param_spec_list);
+ return MATCH_ERROR;
}
*************** gfc_match_decl_type_spec (gfc_typespec *
*** 3829,3834 ****
--- 3904,3922 ----
}
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)
{
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 251949)
--- gcc/fortran/expr.c (working copy)
*************** gfc_replace_expr (gfc_expr *dest, gfc_ex
*** 624,629 ****
--- 624,643 ----
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)
*************** gfc_check_init_expr (gfc_expr *e)
*** 2548,2554 ****
t = true;
/* This occurs when parsing pdt templates. */
! if (e->symtree->n.sym->attr.pdt_kind)
break;
if (gfc_check_iter_variable (e))
--- 2562,2568 ----
t = true;
/* This occurs when parsing pdt templates. */
! if (gfc_expr_attr (e).pdt_kind)
break;
if (gfc_check_iter_variable (e))
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c (revision 251948)
--- gcc/fortran/primary.c (working copy)
*************** gfc_match_actual_arglist (int sub_flag,
*** 1796,1806 ****
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");
--- 1796,1801 ----
*************** gfc_match_actual_arglist (int sub_flag,
*** 1829,1834 ****
--- 1824,1838 ----
}
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
Index: gcc/testsuite/gfortran.dg/pdt_4.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_4.f03 (revision 251948)
--- gcc/testsuite/gfortran.dg/pdt_4.f03 (working copy)
*************** end module
*** 81,88 ****
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" }
end subroutine
subroutine bar(arg) ! { dg-error "cannot have DEFERRED type
parameters" }
type (thytype(8, :, 4) :: arg
--- 81,88 ----
end select
deallocate (cz)
contains
! 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
Index: gcc/testsuite/gfortran.dg/pdt_6.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_6.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_6.f03 (working copy)
***************
*** 0 ****
--- 1,26 ----
+ ! { dg-do compile }
+ !
+ ! Fixes of ICE on invalid & accepts invalid
+ !
+ ! Contributed by Thomas Koenig <[email protected]>
+ !
+ 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
Index: gcc/testsuite/gfortran.dg/pdt_7.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_7.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_7.f03 (working copy)
***************
*** 0 ****
--- 1,20 ----
+ ! { dg-do run }
+ !
+ ! Rejected valid
+ !
+ ! Contributed by Thomas Koenig <[email protected]>
+ !
+ 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
Index: gcc/testsuite/gfortran.dg/pdt_8.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_8.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_8.f03 (working copy)
***************
*** 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 Thomas Koenig <[email protected]>
+ !
+ 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
Index: gcc/testsuite/gfortran.dg/pdt_9.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_9.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_9.f03 (working copy)
***************
*** 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 <[email protected]>
+ !
+ 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
