re PR fortran/82865 (Option -fdec collides with PDT)

2018-06-28  Fritz Reese  <fritzoreese@gmail.com>

    gcc/testsuite/ChangeLog:

	PR fortran/82865
	Backport from trunk.
	* gfortran.dg/dec_type_print_2.f03: New testcase.

    gcc/fortran/ChangeLog:

	PR fortran/82865
	Backport from trunk.
	* decl.c (gfc_match_type): Refactor and check for PDT declarations.

From-SVN: r262224

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 756a330178387792c55cd38c4f73c714f65da3f3..ab64529845744b54168e313acf2c70744820656a 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2018-06-28  Fritz Reese  <fritzoreese@gmail.com>
+
+       PR fortran/82865
+       Backport from trunk.
+       * decl.c (gfc_match_type): Refactor and check for PDT declarations.
+
 2018-06-25  Fritz Reese  <fritzoreese@gmail.com>
 
        PR fortran/82972

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index e73f2d76f4558040f2a89f38294ebb5ae12a5a4d..d2a6101d0b4bfff30c193e45683fc1b27ceebe13 100644 (file)
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -8887,9 +8887,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)
@@ -8916,11 +8916,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>".  */
@@ -8935,29 +8931,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.
@@ -8970,12 +8948,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/ChangeLog b/gcc/testsuite/ChangeLog
index 1752201a47d64294fc2515ba506dbaed47fd5e2f..9c778da4161484798b80caad3738a29d3ce40dd4 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2018-06-28  Fritz Reese  <fritzoreese@gmail.com>
+
+       PR fortran/82865
+       Backport from trunk.
+       * gfortran.dg/dec_type_print_2.f03: New testcase.
+
 2018-06-26  Kelvin Nilsen  <kelvin@gcc.gnu.org>
 
        Backported from mainline

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 (file)
index 0000000..31b8c3a
--- /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