From: Paul Thomas Date: Sun, 17 Sep 2017 18:24:37 +0000 (+0000) Subject: re PR fortran/82173 ([meta-bug] Parameterized derived type errors) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=62d3c075d52f1b92481bd0cdb9b0ef242210f512;p=gcc.git re PR fortran/82173 ([meta-bug] Parameterized derived type errors) 2017-09-17 Paul Thomas PR fortran/82173 * decl.c (gfc_get_pdt_instance): Use the component initializer expression for the default, rather than the parameter value. * resolve.c (resolve_pdt): New function. (resolve_symbol): Call it. Remove false error, prohibiting deferred type parameters for dummy arguments. PR fortran/60483 * primary.c (gfc_match_varspec): If the type of an associate name is unknown and yet there is a match, try resolving the target expression and using its type. 2017-09-17 Paul Thomas PR fortran/82173 * gfortran.dg/pdt_1.f03 : Eliminate spurious error checks. * gfortran.dg/pdt_2.f03 : The same. * gfortran.dg/pdt_3.f03 : The same. * gfortran.dg/pdt_4.f03 : Add 'modtype' and two new errors in module 'bad_vars'. Add error concerning assumed parameters and save attribute. * gfortran.dg/pdt_11.f03 : New test. PR fortran/60483 * gfortran.dg/associate_9.f90 : Remove XFAIL and change to run. * gfortran.dg/associate_25.f90 : New test. * gfortran.dg/pdt_12.f03 : New test. From-SVN: r252894 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8bdd6357af1..b6abf24e2f1 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2017-09-17 Paul Thomas + + PR fortran/82173 + * decl.c (gfc_get_pdt_instance): Use the component initializer + expression for the default, rather than the parameter value. + * resolve.c (resolve_pdt): New function. + (resolve_symbol): Call it. Remove false error, prohibiting + deferred type parameters for dummy arguments. + + PR fortran/60483 + * primary.c (gfc_match_varspec): If the type of an associate + name is unknown and yet there is a match, try resolving the + target expression and using its type. + 2017-09-15 Paul Thomas PR fortran/82184 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index f6e0a7f528f..18220a127c3 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -3275,8 +3275,8 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, kind_expr = gfc_copy_expr (actual_param->expr); else { - if (param->value) - kind_expr = gfc_copy_expr (param->value); + if (c1->initializer) + kind_expr = gfc_copy_expr (c1->initializer); else if (!(actual_param && param->attr.pdt_len)) { gfc_error ("The derived parameter '%qs' at %C does not " diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 25658d7c650..21e5be2b40a 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2055,10 +2055,21 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED) gfc_set_default_type (sym, 0, sym->ns); + /* Before throwing an error try resolving the target expression of + associate names. This should resolve function calls, for example. */ if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES) { - gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name); - return MATCH_ERROR; + if (sym->assoc && sym->assoc->target) + { + gfc_resolve_expr (sym->assoc->target); + sym->ts = sym->assoc->target->ts; + } + + if (sym->ts.type == BT_UNKNOWN) + { + gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name); + return MATCH_ERROR; + } } else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS) && m == MATCH_YES) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 91d05b3e23b..89dea5f7ae2 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -14125,6 +14125,57 @@ resolve_fl_parameter (gfc_symbol *sym) } +/* Called by resolve_symbol to chack PDTs. */ + +static void +resolve_pdt (gfc_symbol* sym) +{ + gfc_symbol *derived = NULL; + gfc_actual_arglist *param; + 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 (); + + gcc_assert (derived->attr.pdt_type); + + for (param = sym->param_list; param; param = param->next) + { + c = gfc_find_component (derived, param->name, false, true, NULL); + gcc_assert (c); + if (c->attr.pdt_kind) + continue; + + if (param->expr && !gfc_is_constant_expr (param->expr) + && c->attr.pdt_len) + const_len_exprs = false; + else if (param->spec_type == SPEC_ASSUMED) + assumed_len_exprs = true; + } + + if (!const_len_exprs + && (sym->ns->proc_name->attr.is_main_program + || sym->ns->proc_name->attr.flavor == FL_MODULE + || sym->attr.save != SAVE_NONE)) + gfc_error ("The AUTOMATIC object %qs at %L must not have the " + "SAVE attribute or be a variable declared in the " + "main program, a module or a submodule(F08/C513)", + sym->name, &sym->declared_at); + + if (assumed_len_exprs && !(sym->attr.dummy + || sym->attr.select_type_temporary || sym->attr.associate_var)) + gfc_error ("The object %qs at %L with ASSUMED type parameters " + "must be a dummy or a SELECT TYPE selector(F08/4.2)", + sym->name, &sym->declared_at); +} + + /* Do anything necessary to resolve a symbol. Right now, we just assume that an otherwise unknown symbol is a variable. This sort of thing commonly happens for symbols in module. */ @@ -14381,15 +14432,6 @@ resolve_symbol (gfc_symbol *sym) return; } - if (sym->attr.dummy && sym->ts.type == BT_DERIVED - && sym->ts.u.derived->attr.pdt_type - && gfc_spec_list_type (sym->param_list, NULL) == SPEC_DEFERRED) - { - gfc_error ("%qs at %L cannot have DEFERRED type parameters because " - "it is a dummy argument", sym->name, &sym->declared_at); - return; - } - if (sym->attr.value && sym->ts.type == BT_CHARACTER) { gfc_charlen *cl = sym->ts.u.cl; @@ -14927,6 +14969,9 @@ resolve_symbol (gfc_symbol *sym) || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)) if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)) return; + + if (sym->param_list) + resolve_pdt (sym); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1a94535b0ee..d40f08e13cf 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,19 @@ +2017-09-17 Paul Thomas + + PR fortran/82173 + * gfortran.dg/pdt_1.f03 : Eliminate spurious error checks. + * gfortran.dg/pdt_2.f03 : The same. + * gfortran.dg/pdt_3.f03 : The same. + * gfortran.dg/pdt_4.f03 : Add 'modtype' and two new errors in + module 'bad_vars'. Add error concerning assumed parameters and + save attribute. + * gfortran.dg/pdt_11.f03 : New test. + + PR fortran/60483 + * gfortran.dg/associate_9.f90 : Remove XFAIL and change to run. + * gfortran.dg/associate_25.f90 : New test. + * gfortran.dg/pdt_12.f03 : New test. + 2017-09-15 Andrew Sutton Jakub Jelinek diff --git a/gcc/testsuite/gfortran.dg/associate_25.f90 b/gcc/testsuite/gfortran.dg/associate_25.f90 new file mode 100644 index 00000000000..5644031e15e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_25.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! Checks the fix for PR60483. +! +! Contributed by Anthony Lewis +! +module A + implicit none + Type T + integer :: val = 2 + contains + final :: testfree + end type + integer :: final_flag = 0 +contains + subroutine testfree(this) + Type(T) this + final_flag = this%val + final_flag + end subroutine + subroutine Testf() + associate(X => T()) ! This was failing: Symbol 'x' at (1) has no IMPLICIT type + final_flag = X%val + end associate +! This should now be 4 but the finalization is not happening. +! TODO put it right! + if (final_flag .ne. 2) call abort + end subroutine Testf +end module + + use A + call Testf +end diff --git a/gcc/testsuite/gfortran.dg/associate_9.f03 b/gcc/testsuite/gfortran.dg/associate_9.f03 index 3a262b6da09..56aad453e37 100644 --- a/gcc/testsuite/gfortran.dg/associate_9.f03 +++ b/gcc/testsuite/gfortran.dg/associate_9.f03 @@ -1,7 +1,6 @@ -! { dg-do compile } +! { dg-do run } ! { dg-options "-std=f2003 -fall-intrinsics" } -! FIXME: Change into run test and remove excess error expectation. ! PR fortran/38936 ! Association to derived-type, where the target type is not know @@ -46,5 +45,3 @@ PROGRAM main IF (x%comp /= 10) CALL abort () END ASSOCIATE END PROGRAM main - -! { dg-excess-errors "Syntex error in IF" } diff --git a/gcc/testsuite/gfortran.dg/pdt_1.f03 b/gcc/testsuite/gfortran.dg/pdt_1.f03 index ac57633978b..9dfdc1d6652 100644 --- a/gcc/testsuite/gfortran.dg/pdt_1.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_1.f03 @@ -21,7 +21,7 @@ end type type(mytype(b=4)) :: z(2) - type(mytype(ftype, pdt_len)) :: z2 + type(mytype(ftype, 4)) :: z2 z(1)%i = 1 z(2)%i = 2 diff --git a/gcc/testsuite/gfortran.dg/pdt_11.f03 b/gcc/testsuite/gfortran.dg/pdt_11.f03 new file mode 100644 index 00000000000..42113ae6b2b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_11.f03 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Rolls together 'len_par_06_pos.f90' and 'len_par_07_pos.f90', both of which +! failed to compile. +! +! Contributed by Reinhold Bader +! +module m_type_decs + + implicit none + + type :: matrix(rk, n, m) + integer, kind :: rk + integer, len :: n = 15, m = 20 + real(rk) :: entry(n, m) + end type matrix + + type :: fdef(rk, n) + integer, kind :: rk = kind(1.0) + integer, len :: n = 15 + end type + +end module + +program test + + use m_type_decs + implicit none + integer, parameter :: rk1=kind(1.d0) + type(matrix(rk1,:,:)), allocatable :: o_matrix + type(fdef(n=:)), allocatable :: o_fdef + + allocate(matrix(rk=rk1)::o_matrix) + + if (o_matrix%n == 15 .and. o_matrix%m == 20) then + write(*,*) 'o_matrix OK' + else + write(*,*) 'o_matrix FAIL' + call abort + end if + + allocate(fdef(n=12)::o_fdef) + + if (o_fdef%n == 12) then + write(*,*) 'o_fdef OK' + else + write(*,*) 'o_fdef FAIL' + call abort + end if +end program test + + diff --git a/gcc/testsuite/gfortran.dg/pdt_12.f03 b/gcc/testsuite/gfortran.dg/pdt_12.f03 new file mode 100644 index 00000000000..8051b27f97a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_12.f03 @@ -0,0 +1,42 @@ +! { dg-do run } +! +! Checks PDTs with ASSOCIATE. +! Was failing for same reason as PR60483. +! +! Contributed by Reinhold Bader +! +module matrix_mod_assumed_05 + + implicit none + + type :: matrix(rk, n, m) + integer, kind :: rk + integer, len :: n, m + real(rk) :: entry(n, m) + end type matrix + integer, parameter :: rk=kind(1.d0) + integer :: mm=20, nn=15 + +contains + function factory() + type(matrix(rk, :, :)), allocatable :: factory + allocate(matrix(rk, nn, mm) :: factory) + end function +end module + +program test + + use matrix_mod_assumed_05 + implicit none + + associate (o_matrix => factory()) + if (o_matrix%n == nn .and. o_matrix%m == mm) then ! Symbol 'o_matrix' at (1) has no IMPLICIT type + write(*,*) 'OK' + else + write(*,*) 'FAIL' + call abort + end if + end associate + +end program test + diff --git a/gcc/testsuite/gfortran.dg/pdt_2.f03 b/gcc/testsuite/gfortran.dg/pdt_2.f03 index f34a9b7f258..34e217dc787 100644 --- a/gcc/testsuite/gfortran.dg/pdt_2.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_2.f03 @@ -7,7 +7,6 @@ ! implicit none integer, parameter :: ftype = kind(0.0e0) - integer :: pdt_len = 4 integer :: i type :: mytype (a,b) integer, kind :: a = kind(0.0d0) @@ -17,7 +16,7 @@ character (len = b*b) :: chr end type - type(mytype(ftype, pdt_len)) :: z2 + type(mytype(ftype, 4)) :: z2 call foobar (z2) contains subroutine foobar (arg) diff --git a/gcc/testsuite/gfortran.dg/pdt_3.f03 b/gcc/testsuite/gfortran.dg/pdt_3.f03 index a097149aab7..02ad757533d 100644 --- a/gcc/testsuite/gfortran.dg/pdt_3.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_3.f03 @@ -34,7 +34,7 @@ end module real, allocatable :: matrix (:,:) type(thytype(ftype, 4, 4)) :: w - type(x(8,4,mat_dim)) :: q + type(x(8,4,256)) :: q class(mytype(ftype, :)), allocatable :: cz w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim]) diff --git a/gcc/testsuite/gfortran.dg/pdt_4.f03 b/gcc/testsuite/gfortran.dg/pdt_4.f03 index f585fae5f1e..13c00af79f1 100644 --- a/gcc/testsuite/gfortran.dg/pdt_4.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_4.f03 @@ -2,13 +2,25 @@ ! ! Test bad PDT coding: Based on pdt_3.f03 ! -module vars +module m integer :: d_dim = 4 integer :: mat_dim = 256 integer, parameter :: ftype = kind(0.0d0) + type :: modtype (a,b) + integer, kind :: a = kind(0.0e0) + integer, LEN :: b = 4 + integer :: i + real(kind = a) :: d(b, b) + end type +end module + +module bad_vars + use m + type(modtype(8,mat_dim)) :: mod_q ! { dg-error "must not have the SAVE attribute" } + type(modtype(8,*)) :: mod_r ! { dg-error "ASSUMED type parameters" } end module - use vars + use m implicit none integer :: i integer, kind :: bad_kind ! { dg-error "not allowed outside a TYPE definition" } @@ -50,7 +62,7 @@ end module type(thytype(:, 4, 4)) :: w_ugh ! { dg-error "cannot either be ASSUMED or DEFERRED" } type(thytype(ftype, b=4, h=4)) :: w - type(x(8,4,mat_dim)) :: q + type(x(8,4,mat_dim)) :: q ! { dg-error "must not have the SAVE attribute" } class(mytype(ftype, :)), allocatable :: cz w%a = 1 ! { dg-error "assignment to a KIND or LEN component" } @@ -82,9 +94,9 @@ end module deallocate (cz) contains subroutine foo(arg) - type (mytype(4, *)) :: arg ! used to have an invalid "is being used before it is defined" + type (mytype(4, *)) :: arg ! OK end subroutine - subroutine bar(arg) ! { dg-error "cannot have DEFERRED type parameters" } + subroutine bar(arg) ! OK type (thytype(8, :, 4) :: arg end subroutine end