Support TYPE as alias for PRINT with -fdec.

	gcc/fortran/
	* decl.c (gfc_match_type): New function.
	* match.h (gfc_match_type): New function.
	* match.c (gfc_match_if): Special case for one-line IFs.
	* gfortran.texi: Update documentation.
	* parse.c (decode_statement): Invoke gfc_match_type.

	gcc/testsuite/gfortran.dg/
	* dec_type_print.f90: New testcase.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@241518 138bc75d-0d04-0410-961f-82ee72b054a4

8 files changed, 218 insertions, 2 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d3971a63610..986eedfde2a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,13 @@
 2016-10-25  Fritz Reese <fritzoreese@gmail.com>
 
+	* decl.c (gfc_match_type): New function.
+	* match.h (gfc_match_type): New function.
+	* match.c (gfc_match_if): Special case for one-line IFs.
+	* gfortran.texi: Update documentation.
+	* parse.c (decode_statement): Invoke gfc_match_type.
+
+2016-10-25  Fritz Reese <fritzoreese@gmail.com>
+
 	* gfortran.texi: Document.
 	* gfortran.h (gfc_is_whitespace): Include form feed ('\f').
 
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index e47d8ede33c..6c9d0570df7 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -8710,6 +8710,100 @@ gfc_match_structure_decl (void)
     return MATCH_YES;
 }
 
+
+/* 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
+ * as an alias for PRINT from derived type declarations, TYPE IS statements,
+ * and derived type data declarations.  */
+
+match
+gfc_match_type (gfc_statement *st)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  match m;
+  locus old_loc;
+
+  /* Requires -fdec.  */
+  if (!flag_dec)
+    return MATCH_NO;
+
+  m = gfc_match ("type");
+  if (m != MATCH_YES)
+    return m;
+  /* If we already have an error in the buffer, it is probably from failing to
+   * match a derived type data declaration. Let it happen.  */
+  else if (gfc_error_flag_test ())
+    return MATCH_NO;
+
+  old_loc = gfc_current_locus;
+  *st = ST_NONE;
+
+  /* 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 ();
+    }
+
+  /* By now "TYPE" has already been matched. If we do not see a name, this may
+   * be something like "TYPE *" or "TYPE <fmt>".  */
+  m = gfc_match_name (name);
+  if (m != MATCH_YES)
+    {
+      /* Let print match if it can, otherwise throw an error from
+       * gfc_match_derived_decl.  */
+      gfc_current_locus = old_loc;
+      if (gfc_match_print () == MATCH_YES)
+	{
+	  *st = ST_WRITE;
+	  return MATCH_YES;
+	}
+      gfc_current_locus = old_loc;
+      *st = ST_DERIVED_DECL;
+      return gfc_match_derived_decl ();
+    }
+
+  /* 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
+    {
+      /* 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.
+       * Otherwise if gfc_match_derived_decl fails it's probably an existing
+       * symbol which can be printed.  */
+      gfc_current_locus = old_loc;
+      m = gfc_match_derived_decl ();
+      if (gfc_is_intrinsic_typename (name) || m == MATCH_YES)
+	{
+	  *st = ST_DERIVED_DECL;
+	  return m;
+	}
+      gfc_current_locus = old_loc;
+      *st = ST_WRITE;
+      return gfc_match_print ();
+    }
+
+  return MATCH_NO;
+}
+
+
 /* Match the beginning of a derived type declaration.  If a type name
    was the result of a function, then it is possible to have a symbol
    already to be known as a derived type yet have no components.  */
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 688b9565e26..fb47c13ceaa 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -1466,6 +1466,7 @@ compatibility extensions along with those enabled by @option{-std=legacy}.
 * AUTOMATIC and STATIC attributes::
 * Extended math intrinsics::
 * Form feed as whitespace::
+* TYPE as an alias for PRINT::
 @end menu
 
 @node Old-style kind specifications
@@ -2521,6 +2522,21 @@ though the Fortran standard does not mention this. GNU Fortran supports the
 interpretation of form feed characters in source as whitespace for
 compatibility.
 
+@node TYPE as an alias for PRINT
+@subsection TYPE as an alias for PRINT
+@cindex type alias print
+For compatibility, GNU Fortran will interpret @code{TYPE} statements as
+@code{PRINT} statements with the flag @option{-fdec}.  With this flag asserted,
+the following two examples are equivalent:
+
+@smallexample
+TYPE *, 'hello world'
+@end smallexample
+
+@smallexample
+PRINT *, 'hello world'
+@end smallexample
+
 
 @node Extensions not implemented in GNU Fortran
 @section Extensions not implemented in GNU Fortran
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index aa9961c6ed5..236231e3ee6 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1622,6 +1622,9 @@ gfc_match_if (gfc_statement *if_type)
   match ("where", match_simple_where, ST_WHERE)
   match ("write", gfc_match_write, ST_WRITE)
 
+  if (flag_dec)
+    match ("type", gfc_match_print, ST_WRITE)
+
   /* The gfc_match_assignment() above may have returned a MATCH_NO
      where the assignment was to a named constant.  Check that
      special case here.  */
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 24131635713..eeb26931567 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -214,6 +214,7 @@ match gfc_match_union (void);
 match gfc_match_structure_decl (void);
 match gfc_match_derived_decl (void);
 match gfc_match_final_decl (void);
+match gfc_match_type (gfc_statement *);
 
 match gfc_match_implicit_none (void);
 match gfc_match_implicit (void);
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 03234358547..760d3afdb5f 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -413,6 +413,12 @@ decode_statement (void)
   gfc_undo_symbols ();
   gfc_current_locus = old_locus;
 
+  /* Try to match TYPE as an alias for PRINT.  */
+  if (gfc_match_type (&st) == MATCH_YES)
+    return st;
+  gfc_undo_symbols ();
+  gfc_current_locus = old_locus;
+
   match (NULL, gfc_match_do, ST_DO);
   match (NULL, gfc_match_block, ST_BLOCK);
   match (NULL, gfc_match_associate, ST_ASSOCIATE);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b2662db6008..a64e74d91d9 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,7 +1,11 @@
 2016-10-25  Fritz Reese <fritzoreese@gmail.com>
 
-	gfortran.dg/
-	* feed_1.f90, feed_2.f90: New testcases.
+	* gfortran.dg/dec_type_print.f90: New testcase.
+
+2016-10-25  Fritz Reese <fritzoreese@gmail.com>
+
+	* gfortran.dg/feed_1.f90: New test.
+	* gfortran.dg/feed_2.f90: New test.
 
 2016-10-25  Martin Liska  <mliska@suse.cz>
 
diff --git a/gcc/testsuite/gfortran.dg/dec_type_print.f90 b/gcc/testsuite/gfortran.dg/dec_type_print.f90
new file mode 100644
index 00000000000..ca407987329
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dec_type_print.f90
@@ -0,0 +1,84 @@
+! { dg-do compile }
+! { dg-options "-fdec" }
+!
+! Test the usage of TYPE as an alias for PRINT.
+!
+! Note the heavy use of other TYPE statements to test for
+! regressions involving ambiguity.
+!
+program main
+
+logical bool
+integer i /0/, j /1/, k /2/
+character(*), parameter :: fmtstr = "(A11)"
+namelist /nmlist/ i, j, k
+integer, parameter :: n = 5
+real a(n)
+
+! derived type declarations
+type is
+  integer i
+end type
+
+type point
+   real x, y
+end type point
+
+type, extends(point) :: point_3d
+   real :: z
+end type point_3d
+
+type, extends(point) :: color_point
+   integer :: color
+end type color_point
+
+! declaration type specification
+type(is) x
+type(point), target :: p
+type(point_3d), target :: p3
+type(color_point), target :: c
+class(point), pointer :: p_or_c
+
+! select type
+p_or_c => c
+select type ( a => p_or_c )
+  class is ( point )
+    print *, "point"     ! <===
+  type is ( point_3d )
+    print *, "point 3D"
+end select
+
+! Type as alias for print
+type*
+type *
+type*,'St','ar'
+type *, 'St', 'ar'
+type 10, 'Integer literal'
+type 10, 'Integer variable'
+type '(A11)', 'Character literal'
+type fmtstr, 'Character variable'
+type nmlist ! namelist
+
+a(1) = 0
+call f(.true., a, n)
+
+10    format (A11)
+
+end program
+
+
+subroutine f(b,a,n)
+  implicit none
+  logical b
+  real a(*)
+  integer n
+
+  integer i
+
+  do i = 2,n
+    a(i) = 2 * (a(i-1) + 1)
+    if (b) type*,a(i) ! test TYPE as PRINT inside one-line IF
+  enddo
+
+  return
+end subroutine