2017-09-17 Paul Thomas <pault@gcc.gnu.org>
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 <pault@gcc.gnu.org>
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
+2017-09-17 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <pault@gcc.gnu.org>
PR fortran/82184
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 "
&& 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)
}
+/* 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. */
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;
|| (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);
}
+2017-09-17 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <andrew.n.sutton@gmail.com>
Jakub Jelinek <jakub@redhat.com>
--- /dev/null
+! { dg-do run }
+!
+! Checks the fix for PR60483.
+!
+! Contributed by Anthony Lewis <antony@cosmologist.info>
+!
+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
-! { 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
IF (x%comp /= 10) CALL abort ()
END ASSOCIATE
END PROGRAM main
-
-! { dg-excess-errors "Syntex error in IF" }
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
--- /dev/null
+! { 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 <reinhold.bader@lrz.de>
+!
+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
+
+
--- /dev/null
+! { dg-do run }
+!
+! Checks PDTs with ASSOCIATE.
+! Was failing for same reason as PR60483.
+!
+! Contributed by Reinhold Bader <reinhold.bader@lrz.de>
+!
+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
+
!
implicit none
integer, parameter :: ftype = kind(0.0e0)
- integer :: pdt_len = 4
integer :: i
type :: mytype (a,b)
integer, kind :: a = kind(0.0d0)
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)
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])
!
! 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" }
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" }
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
projects / gcc.git / commitdiff