One extension enabled by -fdec is the ability to interpret TYPE ....
as a PRINT statement for compatibility purposes. When PDTs were
introduced, the code that handles -fde TYPE matching was not updated.
This patch fixes TYPE matching to no longer interpret <TYPE
name(parameter)> as a PRINT statement when -fdec is asserted. Passes
regression tests as well.
The patch is attached. OK for trunk and 7/8-branch?
0dd08cefc2476014487b3eeab059784ab21bb41b Mon Sep 17 00:00:00 2001
From: Fritz Reese <fritzore...@gmail.com>
Date: Wed, 27 Jun 2018 15:43:45 -0400
Subject: [PATCH 3/3] PR fortran/82865
Do not override PDT declarations from gfc_match_type with -fdec.
gcc/fortran/
* decl.c (gfc_match_type): Refactor and check for PDT declarations.
gcc/testsuite/
* gfortran.dg/dec_type_print_2.f03: New testcase.
---
gcc/fortran/decl.c | 66 +++++++++++++-------------
gcc/testsuite/gfortran.dg/dec_type_print_2.f03 | 59 +++++++++++++++++++++++
2 files changed, 93 insertions(+), 32 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/dec_type_print_2.f03
From 0dd08cefc2476014487b3eeab059784ab21bb41b Mon Sep 17 00:00:00 2001
From: Fritz Reese <fritzore...@gmail.com>
Date: Wed, 27 Jun 2018 15:43:45 -0400
Subject: [PATCH 3/3] PR fortran/82865
Do not override PDT declarations from gfc_match_type with -fdec.
gcc/fortran/
* decl.c (gfc_match_type): Refactor and check for PDT declarations.
gcc/testsuite/
* gfortran.dg/dec_type_print_2.f03: New testcase.
---
gcc/fortran/decl.c | 66 +++++++++++++-------------
gcc/testsuite/gfortran.dg/dec_type_print_2.f03 | 59 +++++++++++++++++++++++
2 files changed, 93 insertions(+), 32 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/dec_type_print_2.f03
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index af724658d8d..ef59d1679ed 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -9607,9 +9607,9 @@ gfc_match_structure_decl (void)
/* This function does some work to determine which matcher should be used to
- * match a statement beginning with "TYPE". This is used to disambiguate TYPE
+ * match a statement beginning with "TYPE". This is used to disambiguate TYPE
* as an alias for PRINT from derived type declarations, TYPE IS statements,
- * and derived type data declarations. */
+ * and [parameterized] derived type declarations. */
match
gfc_match_type (gfc_statement *st)
@@ -9636,11 +9636,7 @@ gfc_match_type (gfc_statement *st)
/* If we see an attribute list before anything else it's definitely a derived
* type declaration. */
if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES)
- {
- gfc_current_locus = old_loc;
- *st = ST_DERIVED_DECL;
- return gfc_match_derived_decl ();
- }
+ goto derived;
/* By now "TYPE" has already been matched. If we do not see a name, this may
* be something like "TYPE *" or "TYPE <fmt>". */
@@ -9655,29 +9651,11 @@ gfc_match_type (gfc_statement *st)
*st = ST_WRITE;
return MATCH_YES;
}
- gfc_current_locus = old_loc;
- *st = ST_DERIVED_DECL;
- return gfc_match_derived_decl ();
+ goto derived;
}
- /* A derived type declaration requires an EOS. Without it, assume print. */
- m = gfc_match_eos ();
- if (m == MATCH_NO)
- {
- /* Check manually for TYPE IS (... - this is invalid print syntax. */
- if (strncmp ("is", name, 3) == 0
- && gfc_match (" (", name) == MATCH_YES)
- {
- gfc_current_locus = old_loc;
- gcc_assert (gfc_match (" is") == MATCH_YES);
- *st = ST_TYPE_IS;
- return gfc_match_type_is ();
- }
- gfc_current_locus = old_loc;
- *st = ST_WRITE;
- return gfc_match_print ();
- }
- else
+ /* Check for EOS. */
+ if (gfc_match_eos () == MATCH_YES)
{
/* By now we have "TYPE <name> <EOS>". Check first if the name is an
* intrinsic typename - if so let gfc_match_derived_decl dump an error.
@@ -9690,12 +9668,36 @@ gfc_match_type (gfc_statement *st)
*st = ST_DERIVED_DECL;
return m;
}
- gfc_current_locus = old_loc;
- *st = ST_WRITE;
- return gfc_match_print ();
}
+ else
+ {
+ /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
+ like <type name(parameter)>. */
+ gfc_gobble_whitespace ();
+ bool paren = gfc_peek_ascii_char () == '(';
+ if (paren)
+ {
+ if (strcmp ("is", name) == 0)
+ goto typeis;
+ else
+ goto derived;
+ }
+ }
+
+ /* Treat TYPE... like PRINT... */
+ gfc_current_locus = old_loc;
+ *st = ST_WRITE;
+ return gfc_match_print ();
- return MATCH_NO;
+derived:
+ gfc_current_locus = old_loc;
+ *st = ST_DERIVED_DECL;
+ return gfc_match_derived_decl ();
+
+typeis:
+ gfc_current_locus = old_loc;
+ *st = ST_TYPE_IS;
+ return gfc_match_type_is ();
}
diff --git a/gcc/testsuite/gfortran.dg/dec_type_print_2.f03 b/gcc/testsuite/gfortran.dg/dec_type_print_2.f03
new file mode 100644
index 00000000000..31b8c3ad934
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dec_type_print_2.f03
@@ -0,0 +1,59 @@
+! { dg-do run }
+! { dg-options "-fdec -fcheck=all" }
+!
+! Verify that -fdec does not break parsing of PDTs.
+! This test code is copied from pdt_1.f03 but compiled with -fdec.
+!
+program main
+ implicit none
+ integer, parameter :: ftype = kind(0.0e0)
+ integer :: pdt_len = 4
+ integer :: i
+ type :: mytype (a,b)
+ integer, kind :: a = kind(0.0d0)
+ integer, LEN :: b
+ integer :: i
+ real(kind = a) :: d(b, b)
+ character (len = b*b) :: chr
+ end type
+
+ type(mytype(b=4)) :: z(2)
+ type(mytype(ftype, 4)) :: z2
+
+ z(1)%i = 1
+ z(2)%i = 2
+ z(1)%d = reshape ([(real(i), i = 1, 16)],[4,4])
+ z(2)%d = 10*z(1)%d
+ z(1)%chr = "hello pdt"
+ z(2)%chr = "goodbye pdt"
+
+ z2%d = z(1)%d * 10 - 1
+ z2%chr = "scalar pdt"
+
+ call foo (z)
+ call bar (z)
+ call foobar (z2)
+contains
+ elemental subroutine foo (arg)
+ type(mytype(8,*)), intent(in) :: arg
+ if (arg%i .eq. 1) then
+ if (trim (arg%chr) .ne. "hello pdt") error stop
+ if (int (sum (arg%d)) .ne. 136) error stop
+ else if (arg%i .eq. 2 ) then
+ if (trim (arg%chr) .ne. "goodbye pdt") error stop
+ if (int (sum (arg%d)) .ne. 1360) error stop
+ else
+ error stop
+ end if
+ end subroutine
+ subroutine bar (arg)
+ type(mytype(b=4)) :: arg(:)
+ if (int (sum (arg(1)%d)) .ne. 136) call abort
+ if (trim (arg(2)%chr) .ne. "goodbye pdt") call abort
+ end subroutine
+ subroutine foobar (arg)
+ type(mytype(ftype, pdt_len)) :: arg
+ if (int (sum (arg%d)) .ne. 1344) call abort
+ if (trim (arg%chr) .ne. "scalar pdt") call abort
+ end subroutine
+end
--
2.12.2
