Hi All, This patch detects mismatched, constant PDT type specification parameters in array constructors and assignment. It is completely straightforward and sufficiently described by the ChangeLog.
In preparing the testcase, I noticed that assignment of one PDT variable array to another was not being scalarized but, instead being copied directly. While this is OK for PDTs with no len parameters, parameterized arrays or strings, it is not generally correct. The fix is the one-liner in trans-expr.cc. Regtests on FC43/x86_64 - OK for mainline? Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index be2eb595317..e9199f3e77f 100644
--- a/gcc/fortran/array.cc
+++ b/gcc/fortran/array.cc
@@ -2214,6 +2214,7 @@ resolve_array_list (gfc_constructor_base base)
bool t;
gfc_constructor *c;
gfc_iterator *iter;
+ gfc_expr *expr1 = NULL;
t = true;
@@ -2276,6 +2277,17 @@ resolve_array_list (gfc_constructor_base base)
t = false;
}
+ /* For valid expressions, check that the type specification parameters
+ are the same. */
+ if (t && !c->iterator && c->expr
+ && c->expr->ts.type == BT_DERIVED
+ && c->expr->ts.u.derived->attr.pdt_type)
+ {
+ if (expr1 == NULL)
+ expr1 = c->expr;
+ else
+ t = gfc_check_type_spec_parms (expr1, c->expr, "in array constructor");
+ }
}
return t;
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index a2f19607eb1..a47e970eda9 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -3930,6 +3930,67 @@ gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, .
}
+/* Functions to check constant valued type specification parameters. */
+
+static gfc_actual_arglist *
+get_parm_list_from_expr (gfc_expr *expr)
+{
+ gfc_actual_arglist *a = NULL;
+ gfc_constructor *c;
+
+ if (expr->expr_type == EXPR_STRUCTURE)
+ a = expr->param_list;
+ else if (expr->expr_type == EXPR_ARRAY)
+ {
+ /* Take the first constant expression, if there is one. */
+ c = gfc_constructor_first (expr->value.constructor);
+ for (; c; c = gfc_constructor_next (c))
+ if (!c->iterator && c->expr && c->expr->param_list)
+ {
+ a = c->expr->param_list;
+ break;
+ }
+ }
+ else if (expr->expr_type == EXPR_VARIABLE)
+ a = expr->symtree->n.sym->param_list;
+
+ return a;
+}
+
+bool
+gfc_check_type_spec_parms (gfc_expr *expr1, gfc_expr *expr2,
+ const char *context)
+{
+ bool t = true;
+ gfc_actual_arglist *a1, *a2;
+
+ gcc_assert (expr1->ts.type == BT_DERIVED
+ && expr1->ts.u.derived->attr.pdt_type);
+
+ a1 = get_parm_list_from_expr (expr1);
+ a2 = get_parm_list_from_expr (expr2);
+
+ for (; a1 && a2; a1 = a1->next, a2 = a2->next)
+ {
+ if (a1->expr && a1->expr->expr_type == EXPR_CONSTANT
+ && a2->expr && a2->expr->expr_type == EXPR_CONSTANT
+ && !strcmp (a1->name, a2->name)
+ && mpz_cmp (a1->expr->value.integer, a2->expr->value.integer))
+ {
+ gfc_error ("Mismatched type parameters %qs(%d/%d) %s at %L/%L",
+ a2->name,
+ (int)mpz_get_ui (a1->expr->value.integer),
+ (int)mpz_get_ui (a2->expr->value.integer),
+ context,
+ &expr1->where, &expr2->where);
+ t = false;
+ }
+ }
+
+ return t;
+}
+
+
/* Given an assignable expression and an arbitrary expression, make
sure that the assignment can take place. Only add a call to the intrinsic
conversion routines, when allow_convert is set. When this assign is a
@@ -4123,6 +4184,12 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
return false;
}
+
+ /* Check that the type spec. parameters are the same on both sides. */
+ if (lvalue->ts.type == BT_DERIVED && lvalue->ts.u.derived->attr.pdt_type
+ && !gfc_check_type_spec_parms (lvalue, rvalue, "in assignment"))
+ return false;
+
if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
return true;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index cafd3ab53fe..72b4c80487c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3998,6 +3998,7 @@ bool gfc_numeric_ts (gfc_typespec *);
int gfc_kind_max (gfc_expr *, gfc_expr *);
bool gfc_check_conformance (gfc_expr *, gfc_expr *, const char *, ...) ATTRIBUTE_PRINTF_3;
+bool gfc_check_type_spec_parms (gfc_expr *, gfc_expr *, const char *);
bool gfc_check_assign (gfc_expr *, gfc_expr *, int, bool c = true);
bool gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue,
bool suppres_type_test = false,
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 33adff6b919..eb050506a34 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -13612,7 +13612,8 @@ copyable_array_p (gfc_expr * expr)
return false;
case_bt_struct:
- return !expr->ts.u.derived->attr.alloc_comp;
+ return (!expr->ts.u.derived->attr.alloc_comp
+ && !expr->ts.u.derived->attr.pdt_type);
default:
break;
diff --git a/gcc/testsuite/gfortran.dg/pdt_81.f03 b/gcc/testsuite/gfortran.dg/pdt_81.f03
new file mode 100644
index 00000000000..0a0c3037f2f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_81.f03
@@ -0,0 +1,48 @@
+! { dg-do compile )
+!
+! Test the fix for PR112460, in which mismatched, constant typespec parameters were
+! not detected.
+!
+! Contributed by Juergen Reuter <[email protected]>
+!
+module color_propagator
+ implicit none
+ integer, parameter :: pk = kind (1.0)
+ type :: t (k, n_in, n_out)
+ integer, kind :: k = pk
+ integer, len :: n_in = 0, n_out = 0
+ logical :: is_ghost = .false.
+ integer, dimension(n_in) :: in
+ integer, dimension(n_out) :: out
+ end type t
+end module color_propagator
+
+program foo
+ use color_propagator
+ type(t(n_out=1)) :: aa
+ type(t(n_in=1,n_out=2)) :: bb
+ type(t), dimension(3) :: cc, dd, ee, gg
+ type(t(pk,n_in=1,n_out=2)), dimension(3) :: ff, hh
+ type(t(kind(1d0),n_in=1,n_out=2)), dimension(3) :: ii
+ type(t(pk,n_in=1,n_out=1)), dimension(3) :: jj
+ integer :: i
+
+! Starting point was mismatched parameters in array constructors; eg.:
+! Error: Mismatched type parameters ‘n_in’(1/0) in array constructor at (1)/(2)
+
+ cc = [t(pk,1,1)(.true.,[5] ,[6]), aa, bb] ! { dg-error "Mismatched type parameters" }
+ dd = [aa, [t(pk,1,2)(.true.,[5] ,[6,6]), bb]] ! { dg-error "Mismatched type parameters" }
+ ee = [bb, [t(pk,1,2)(.true.,[5],[6,6]), aa]] ! { dg-error "Mismatched type parameters" }
+ ff = [bb, [t(pk,1,2)(.true.,[5],[6,6]), bb]] ! OK
+ gg = [bb, [t(kind (1d0),1,2)(.true.,[5],[6,6]), bb]] ! { dg-error "Mismatched type parameters" }
+
+! Test ordinary assignment; eg.:
+! Error: Mismatched type parameters ‘k’(8/4) in assignment at (1)/(2)
+
+ aa = t(pk,1,2)(.true.,[5] ,[6,7]) ! { dg-error "Mismatched type parameters" }
+ bb = t(pk,1,2)(.true.,[5] ,[6,7]) ! OK
+ hh = ff ! OK
+ ii = ff ! { dg-error "Mismatched type parameters" }
+ jj = ff ! { dg-error "Mismatched type parameters" }
+ print *, ff
+end program foo
