From b00acc54143e8252153fb47e2367ac33833d4020 Mon Sep 17 00:00:00 2001 From: Fritz Reese Date: Tue, 11 Oct 2016 15:32:38 -0400 Subject: [PATCH 2/4] New flag -fdec-type-print for TYPE as alias for PRINT. 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. * invoke.texi: Update documentation. * lang.opt: New flag -fdec-type-print. * options.c (set_dec_flags): Enable with -fdec. * parse.c (decode_statement): Invoke gfc_match_type. gcc/testsuite/gfortran.dg/ * dec_type_print.f90: New testcase. --- gcc/fortran/decl.c | 94 ++++++++++++++++++++++++++ gcc/fortran/gfortran.texi | 16 +++++ gcc/fortran/invoke.texi | 9 ++- gcc/fortran/lang.opt | 4 + gcc/fortran/match.c | 3 + gcc/fortran/match.h | 1 + gcc/fortran/options.c | 1 + gcc/fortran/parse.c | 6 ++ gcc/testsuite/gfortran.dg/dec_type_print.f90 | 84 +++++++++++++++++++++++ 9 files changed, 216 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/dec_type_print.f90 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index bc27f66..367fdfe 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-type-print. */ + if (!flag_dec_type_print) + 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 ". */ + 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 ". 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 affe873..2aa9bad 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -1465,6 +1465,7 @@ without warning. * AUTOMATIC and STATIC attributes:: * Extended math intrinsics:: * Form feed as whitespace:: +* TYPE as an alias for PRINT:: @end menu @node Old-style kind specifications @@ -2519,6 +2520,21 @@ ASCII 0xC) at the beginning of lines for formatted output to line printers. GNU Fortran supports the interpretation of form feed characters in source as whitespace with @option{-fdec-feed} for compatibility. +@node TYPE as an alias for PRINT +@subsection TYPE as an alias for PRINT +@cindex type alias print +For DEC compatibility, the flag @option{-fdec-type-print} will allow +@code{TYPE} statements to be interpreted as @code{PRINT} statements. +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/invoke.texi b/gcc/fortran/invoke.texi index 62c63a6..0e54ee9 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -117,7 +117,7 @@ by type. Explanations are in the following sections. @gccoptlist{-fall-intrinsics -fbackslash -fcray-pointer -fd-lines-as-code @gol -fd-lines-as-comments @gol -fdec -fdec-structure -fdec-intrinsic-ints -fdec-static -fdec-math @gol --fdec-feed @gol +-fdec-feed -fdec-type-print @gol -fdefault-double-8 -fdefault-integer-8 @gol -fdefault-real-8 -fdollar-ok -ffixed-line-length-@var{n} @gol -ffixed-line-length-none -ffree-form -ffree-line-length-@var{n} @gol @@ -243,7 +243,7 @@ full documentation. Other flags enabled by this switch are: @option{-fdollar-ok} @option{-fcray-pointer} @option{-fdec-structure} @option{-fdec-intrinsic-ints} @option{-fdec-static} @option{-fdec-math} -@option{-fdec-feed} +@option{-fdec-feed} @option{-fdec-type-print} @item -fdec-structure @opindex @code{fdec-structure} @@ -271,6 +271,11 @@ the storage of variables and other objects. @opindex @code{fdec-feed} Treat form feed ('\f') characters as whitespace in the source for compatibility. +@item -fdec-type-print +@opindex @code{-fdec-type-print} +Interpret TYPE as an alias for PRINT whenever it can be disambiguated from +derived type data and type declarations and TYPE IS statements. + @item -fdollar-ok @opindex @code{fdollar-ok} @cindex @code{$} diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 4654abf..c09d5a5 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -440,6 +440,10 @@ fdec-static Fortran Var(flag_dec_static) Enable DEC-style STATIC and AUTOMATIC attributes. +fdec-type-print +Fortran Var(flag_dec_type_print) +Enable TYPE as an alias for PRINT. + fdefault-double-8 Fortran Var(flag_default_double) Set the default double precision kind to an 8 byte wide type. diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 9056cb7..067f27c 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_type_print) + 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 2413163..eeb2693 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/options.c b/gcc/fortran/options.c index 4579991..eb46c4a 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -57,6 +57,7 @@ set_dec_flags (int value) flag_dec_static = value; flag_dec_math = value; flag_dec_feed = value; + flag_dec_type_print = value; } diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 3d45ec7..016fe39 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/gfortran.dg/dec_type_print.f90 b/gcc/testsuite/gfortran.dg/dec_type_print.f90 new file mode 100644 index 0000000..84fae7c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_type_print.f90 @@ -0,0 +1,84 @@ +! { dg-do compile } +! { dg-options "-fdec-type-print" } +! +! 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 -- 1.7.1