aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/ChangeLog14
-rw-r--r--gcc/fortran/decl.c4
-rw-r--r--gcc/fortran/primary.c15
-rw-r--r--gcc/fortran/resolve.c63
-rw-r--r--gcc/testsuite/ChangeLog16
-rw-r--r--gcc/testsuite/gfortran.dg/associate_25.f9032
-rw-r--r--gcc/testsuite/gfortran.dg/associate_9.f035
-rw-r--r--gcc/testsuite/gfortran.dg/pdt_1.f032
-rw-r--r--gcc/testsuite/gfortran.dg/pdt_11.f0352
-rw-r--r--gcc/testsuite/gfortran.dg/pdt_12.f0342
-rw-r--r--gcc/testsuite/gfortran.dg/pdt_2.f033
-rw-r--r--gcc/testsuite/gfortran.dg/pdt_3.f032
-rw-r--r--gcc/testsuite/gfortran.dg/pdt_4.f0322
13 files changed, 246 insertions, 26 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8bdd635..b6abf24 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+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
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index f6e0a7f..18220a1 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 25658d7..21e5be2 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 91d05b3..89dea5f 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 1a94535..d40f08e 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,19 @@
+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>
diff --git a/gcc/testsuite/gfortran.dg/associate_25.f90 b/gcc/testsuite/gfortran.dg/associate_25.f90
new file mode 100644
index 0000000..5644031
--- /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 <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
diff --git a/gcc/testsuite/gfortran.dg/associate_9.f03 b/gcc/testsuite/gfortran.dg/associate_9.f03
index 3a262b6..56aad45 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 ac57633..9dfdc1d 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 0000000..42113ae
--- /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 <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
+
+
diff --git a/gcc/testsuite/gfortran.dg/pdt_12.f03 b/gcc/testsuite/gfortran.dg/pdt_12.f03
new file mode 100644
index 0000000..8051b27
--- /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 <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
+
diff --git a/gcc/testsuite/gfortran.dg/pdt_2.f03 b/gcc/testsuite/gfortran.dg/pdt_2.f03
index f34a9b7..34e217d 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 a097149..02ad757 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 f585fae..13c00af 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
generated by cgit v1.1 at 2025-05-21 22:09:57 +0000