+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.
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. */
* AUTOMATIC and STATIC attributes::
* Extended math intrinsics::
* Form feed as whitespace::
+* TYPE as an alias for PRINT::
@end menu
@node Old-style kind specifications
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
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. */
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);
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);
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>
--- /dev/null
+! { 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
projects / gcc.git / commitdiff