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

gcc/fortran/ChangeLog

+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.

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 ();
 }
 
 

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/dec_type_print_2.f03

+! { 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