From 58b9de9ef5238347cc85c7d3e40261c3a3e28e6c Mon Sep 17 00:00:00 2001 From: Fritz Reese Date: Thu, 28 Jun 2018 15:31:24 +0000 Subject: [PATCH] re PR fortran/82865 (Option -fdec collides with PDT) 2018-06-28 Fritz Reese 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 | 5 ++ gcc/fortran/decl.c | 66 ++++++++++--------- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/dec_type_print_2.f03 | 59 +++++++++++++++++ 4 files changed, 103 insertions(+), 32 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/dec_type_print_2.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 6e1af2e3053..e11f34a2caa 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,8 @@ +2018-06-28 Fritz Reese + + PR fortran/82865 + * decl.c (gfc_match_type): Refactor and check for PDT declarations. + 2018-06-28 Martin Liska * gfortranspec.c: Include opt-suggestions.h. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 707c2a74bbb..09541da2577 100644 --- 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 ". */ @@ -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 ". 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 ". Check for or a PDT declaration + like . */ + 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 e3a52b5db95..c95ec808b74 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2018-06-28 Fritz Reese + + PR fortran/82865 + * gfortran.dg/dec_type_print_2.f03: New testcase. + 2018-06-28 David Pagan 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 index 00000000000..31b8c3ad934 --- /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 -- 2.30.2