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

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

    gcc/fortran/ChangeLog:

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

    gcc/testsuite/ChangeLog:

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

From-SVN: r262221

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6e1af2e3053146b2db5c1e2a0b69580459cf9407..e11f34a2caa2362fe6767593ad04ca2ffcccd579 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,8 @@
+2018-06-28  Fritz Reese  <fritzoreese@gmail.com>
+
+       PR fortran/82865
+       * decl.c (gfc_match_type): Refactor and check for PDT declarations.
+
 2018-06-28  Martin Liska  <mliska@suse.cz>
 
        * gfortranspec.c: Include opt-suggestions.h.

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 707c2a74bbb0cd01244655b2d39c996095209070..09541da2577909e9c46aec30fb14d308ed32ae46 100644 (file)
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -9803,9 +9803,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)
@@ -9832,11 +9832,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>".  */
@@ -9851,29 +9847,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.
@@ -9886,12 +9864,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 e3a52b5db9529eaf51fd53bddf9540434d104cd3..c95ec808b74d92bb2f6d245963469323e3e41d8c 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-06-28  Fritz Reese  <fritzoreese@gmail.com>
+
+       PR fortran/82865
+       * gfortran.dg/dec_type_print_2.f03: New testcase.
+
 2018-06-28  David Pagan  <dave.pagan@oracle.com>
 
        PR c/55976

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