From patchwork Sun Oct 31 03:32:59 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Steve Kargl X-Patchwork-Id: 69688 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 3D389B70E0 for ; Sun, 31 Oct 2010 14:33:16 +1100 (EST) Received: (qmail 23724 invoked by alias); 31 Oct 2010 03:33:12 -0000 Received: (qmail 23706 invoked by uid 22791); 31 Oct 2010 03:33:09 -0000 X-SWARE-Spam-Status: No, hits=-2.0 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from troutmask.apl.washington.edu (HELO troutmask.apl.washington.edu) (128.208.78.105) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sun, 31 Oct 2010 03:33:01 +0000 Received: from troutmask.apl.washington.edu (localhost.apl.washington.edu [127.0.0.1]) by troutmask.apl.washington.edu (8.14.4/8.14.4) with ESMTP id o9V3WxSJ044514; Sat, 30 Oct 2010 20:32:59 -0700 (PDT) (envelope-from sgk@troutmask.apl.washington.edu) Received: (from sgk@localhost) by troutmask.apl.washington.edu (8.14.4/8.14.4/Submit) id o9V3Wxem044513; Sat, 30 Oct 2010 20:32:59 -0700 (PDT) (envelope-from sgk) Date: Sat, 30 Oct 2010 20:32:59 -0700 From: Steve Kargl To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: [PATCH] PR fortran/46152 -- fix namespace pollution in type-spec matching Message-ID: <20101031033259.GA44499@troutmask.apl.washington.edu> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.4.2.3i Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org See the PR for a thorough discussion of the problem and the fix. The attached patch has been tested on i686-*-freebsd without regression. I plan to commit this within the next 24 hours. 2010-10-30 Steven G. Kargl PR fortran/46152 * gfortran.dg/select_type_11.f03: Update dg-error phrase. * gfortran.dg/allocate_with_typespec_4.f90: New test. * gfortran.dg/allocate_with_typespec_1.f90: New test. * gfortran.dg/allocate_with_typespec_2.f: New test. * gfortran.dg/allocate_with_typespec_3.f90: New test. * gfortran.dg/allocate_derived_1.f90: Delete an obselescent test. * gfortran.dg/select_type_1.f03: Update dg-error phrase. 2010-10-30 Steven G. Kargl PR fortran/46152 * fortran/match.c (match_derived_type_spec): Reoplace gfc_match_symbol with a gfc_find_symbol to prevent namespace pollution. Remove dead code. (match_type_spec): Remove parsing of '::'. Collapse character kind checking to one location. (gfc_match_allocate): Use correct locus in error message. Index: gcc/testsuite/gfortran.dg/select_type_11.f03 =================================================================== --- gcc/testsuite/gfortran.dg/select_type_11.f03 (revision 166091) +++ gcc/testsuite/gfortran.dg/select_type_11.f03 (working copy) @@ -19,7 +19,7 @@ contains class(vector_class), intent(in) :: v select type (v) - class is (bad_id) ! { dg-error "is not an accessible derived type" } + class is (bad_id) ! { dg-error " error in CLASS IS specification" } this%elements(:) = v%elements(:) ! { dg-error "is not a member of" } end select Index: gcc/testsuite/gfortran.dg/allocate_with_typespec_4.f90 =================================================================== --- gcc/testsuite/gfortran.dg/allocate_with_typespec_4.f90 (revision 0) +++ gcc/testsuite/gfortran.dg/allocate_with_typespec_4.f90 (revision 0) @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-w" } +subroutine not_an_f03_intrinsic + + implicit none + + byte, allocatable :: x, y(:) + real*8, allocatable :: x8, y8(:) + double complex :: z + + type real_type + integer mytype + end type real_type + + type(real_type), allocatable :: b, c(:) + + allocate(byte :: x) ! { dg-error "not a nonprocedure pointer or an allocatable" } + allocate(byte :: y(1)) ! { dg-error "not a nonprocedure pointer or an allocatable" } + + allocate(real*8 :: x) ! { dg-error "Invalid type-spec at" } + allocate(real*8 :: y(1)) ! { dg-error "Invalid type-spec at" } + allocate(real*4 :: x8) ! { dg-error "Invalid type-spec at" } + allocate(real*4 :: y8(1)) ! { dg-error "Invalid type-spec at" } + allocate(double complex :: d1) ! { dg-error "not a nonprocedure pointer or an allocatable" } + allocate(real_type :: b) + allocate(real_type :: c(1)) + +end subroutine not_an_f03_intrinsic Index: gcc/testsuite/gfortran.dg/allocate_with_typespec_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/allocate_with_typespec_1.f90 (revision 0) +++ gcc/testsuite/gfortran.dg/allocate_with_typespec_1.f90 (revision 0) @@ -0,0 +1,121 @@ +! { dg-do compile } +! +! Allocation of arrays with a type-spec specification with implicit none. +! +subroutine implicit_none_test1 + + implicit none + + real, allocatable :: x(:) + real(4), allocatable :: x4(:) + real(8), allocatable :: x8(:) + double precision, allocatable :: d1(:) + doubleprecision, allocatable :: d2(:) + character, allocatable :: c1(:) + character(len=4), allocatable :: c2(:) + + type a + integer mytype + end type a + + type(a), allocatable :: b(:) + + allocate(real :: x(1)) + allocate(real(4) :: x4(1)) + allocate(real(8) :: x8(1)) + allocate(double precision :: d1(1)) + allocate(doubleprecision :: d2(1)) + allocate(character :: c1(1)) + allocate(character(len=4) :: c2(1)) + allocate(a :: b(1)) + +end subroutine implicit_none_test1 +! +! Allocation of a scalar with a type-spec specification with implicit none +! +subroutine implicit_none_test2 + + implicit none + + real, allocatable :: x + real(4), allocatable :: x4 + real(8), allocatable :: x8 + double precision, allocatable :: d1 + doubleprecision, allocatable :: d2 + character, allocatable :: c1 + character(len=4), allocatable :: c2 + + type a + integer mytype + end type a + + type(a), allocatable :: b + + allocate(real :: x) + allocate(real(4) :: x4) + allocate(real(8) :: x8) + allocate(double precision :: d1) + allocate(doubleprecision :: d2) + allocate(character :: c1) + allocate(character(len=4) :: c2) + allocate(a :: b) + +end subroutine implicit_none_test2 +! +! Allocation of arrays with a type-spec specification with implicit none. +! +subroutine implicit_test3 + + real, allocatable :: x(:) + real(4), allocatable :: x4(:) + real(8), allocatable :: x8(:) + double precision, allocatable :: d1(:) + doubleprecision, allocatable :: d2(:) + character, allocatable :: c1(:) + character(len=4), allocatable :: c2(:) + + type a + integer mytype + end type a + + type(a), allocatable :: b(:) + + allocate(real :: x(1)) + allocate(real(4) :: x4(1)) + allocate(real(8) :: x8(1)) + allocate(double precision :: d1(1)) + allocate(doubleprecision :: d2(1)) + allocate(character :: c1(1)) + allocate(character(len=4) :: c2(1)) + allocate(a :: b(1)) + +end subroutine implicit_test3 +! +! Allocation of a scalar with a type-spec specification without implicit none +! +subroutine implicit_test4 + + real, allocatable :: x + real(4), allocatable :: x4 + real(8), allocatable :: x8 + double precision, allocatable :: d1 + doubleprecision, allocatable :: d2 + character, allocatable :: c1 + character(len=4), allocatable :: c2 + + type a + integer mytype + end type a + + type(a), allocatable :: b + + allocate(real :: x) + allocate(real(4) :: x4) + allocate(real(8) :: x8) + allocate(double precision :: d1) + allocate(doubleprecision :: d2) + allocate(character :: c1) + allocate(character(len=4) :: c2) + allocate(a :: b) + +end subroutine implicit_test4 Index: gcc/testsuite/gfortran.dg/allocate_with_typespec_2.f =================================================================== --- gcc/testsuite/gfortran.dg/allocate_with_typespec_2.f (revision 0) +++ gcc/testsuite/gfortran.dg/allocate_with_typespec_2.f (revision 0) @@ -0,0 +1,121 @@ +C { dg-do compile } +C +C Allocation of arrays with a type-spec specification with implicit none. +C + subroutine implicit_none_test1 + + implicit none + + real, allocatable :: x(:) + real(4), allocatable :: x4(:) + real(8), allocatable :: x8(:) + double precision, allocatable :: d1(:) + doubleprecision, allocatable :: d2(:) + character, allocatable :: c1(:) + character(len=4), allocatable :: c2(:) + + type a + integer mytype + end type a + + type(a), allocatable :: b(:) + + allocate(real :: x(1)) + allocate(real(4) :: x4(1)) + allocate(real(8) :: x8(1)) + allocate(double precision :: d1(1)) + allocate(doubleprecision :: d2(1)) + allocate(character :: c1(1)) + allocate(character(len=4) :: c2(1)) + allocate(a :: b(1)) + + end +C +C Allocation of a scalar with a type-spec specification with implicit none +C + subroutine implicit_none_test2 + + implicit none + + real, allocatable :: x + real(4), allocatable :: x4 + real(8), allocatable :: x8 + double precision, allocatable :: d1 + doubleprecision, allocatable :: d2 + character, allocatable :: c1 + character(len=4), allocatable :: c2 + + type a + integer mytype + end type a + + type(a), allocatable :: b + + allocate(real :: x) + allocate(real(4) :: x4) + allocate(real(8) :: x8) + allocate(double precision :: d1) + allocate(doubleprecision :: d2) + allocate(character :: c1) + allocate(character(len=4) :: c2) + allocate(a :: b) + + end subroutine implicit_none_test2 +C +C Allocation of arrays with a type-spec specification with implicit none. +C + subroutine implicit_test3 + + real, allocatable :: x(:) + real(4), allocatable :: x4(:) + real(8), allocatable :: x8(:) + double precision, allocatable :: d1(:) + doubleprecision, allocatable :: d2(:) + character, allocatable :: c1(:) + character(len=4), allocatable :: c2(:) + + type a + integer mytype + end type a + + type(a), allocatable :: b(:) + + allocate(real :: x(1)) + allocate(real(4) :: x4(1)) + allocate(real(8) :: x8(1)) + allocate(double precision :: d1(1)) + allocate(doubleprecision :: d2(1)) + allocate(character :: c1(1)) + allocate(character(len=4) :: c2(1)) + allocate(a :: b(1)) + + end +C +C Allocation of a scalar with a type-spec specification without implicit none +C + subroutine implicit_test4 + + real, allocatable :: x + real(4), allocatable :: x4 + real(8), allocatable :: x8 + double precision, allocatable :: d1 + doubleprecision, allocatable :: d2 + character, allocatable :: c1 + character(len=4), allocatable :: c2 + + type a + integer mytype + end type a + + type(a), allocatable :: b + + allocate(real :: x) + allocate(real(4) :: x4) + allocate(real(8) :: x8) + allocate(double precision :: d1) + allocate(doubleprecision :: d2) + allocate(character :: c1) + allocate(character(len=4) :: c2) + allocate(a :: b) + + end Index: gcc/testsuite/gfortran.dg/allocate_with_typespec_3.f90 =================================================================== --- gcc/testsuite/gfortran.dg/allocate_with_typespec_3.f90 (revision 0) +++ gcc/testsuite/gfortran.dg/allocate_with_typespec_3.f90 (revision 0) @@ -0,0 +1,107 @@ +! { dg-do compile } +! +! Allocation of arrays with a type-spec specification with implicit none. +! +subroutine implicit_none_test1 + + implicit none + + real, allocatable :: x(:) + real(4), allocatable :: x4(:) + real(8), allocatable :: x8(:) + double precision, allocatable :: d1(:) + doubleprecision, allocatable :: d2(:) + character, allocatable :: c1(:) + + type a + integer mytype + end type a + + type(a), allocatable :: b(:) + + allocate(complex :: x(1)) ! { dg-error "is type incompatible" } + allocate(real(8) :: x4(1)) ! { dg-error "differs from the kind type parameter" } + allocate(real(4) :: x8(1)) ! { dg-error "differs from the kind type parameter" } + allocate(double :: d1(1)) ! { dg-error "not a nonprocedure pointer or an allocatable" } + allocate(character(:) :: c1(1)) ! { dg-error "Syntax error in CHARACTER declaration" } + allocate(real :: b(1)) ! { dg-error "is type incompatible" } + +end subroutine implicit_none_test1 +! +! Allocation of a scalar with a type-spec specification with implicit none +! +subroutine implicit_none_test2 + + implicit none + + real, allocatable :: x + real(4), allocatable :: x4 + real(8), allocatable :: x8 + double precision, allocatable :: d1 + character, allocatable :: c1 + + type a + integer mytype + end type a + + type(a), allocatable :: b + + allocate(complex :: x) ! { dg-error "is type incompatible" } + allocate(real(8) :: x4) ! { dg-error "differs from the kind type parameter" } + allocate(real(4) :: x8) ! { dg-error "differs from the kind type parameter" } + allocate(double :: d1) ! { dg-error "not a nonprocedure pointer or an allocatable" } + allocate(character(:) :: c1) ! { dg-error "Syntax error in CHARACTER declaration" } + allocate(real :: b) ! { dg-error "is type incompatible" } + +end subroutine implicit_none_test2 +! +! Allocation of arrays with a type-spec specification with implicit none. +! +subroutine implicit_test3 + + real, allocatable :: x(:) + real(4), allocatable :: x4(:) + real(8), allocatable :: x8(:) + double precision, allocatable :: d1(:) + doubleprecision, allocatable :: d2(:) + character, allocatable :: c1(:) + + type a + integer mytype + end type a + + type(a), allocatable :: b(:) + + allocate(complex :: x(1)) ! { dg-error "is type incompatible" } + allocate(real(8) :: x4(1)) ! { dg-error "differs from the kind type parameter" } + allocate(real(4) :: x8(1)) ! { dg-error "differs from the kind type parameter" } + allocate(double :: d1(1)) ! { dg-error "not a nonprocedure pointer or an allocatable" } + allocate(character(:) :: c1(1)) ! { dg-error "Syntax error in CHARACTER declaration" } + allocate(real :: b(1)) ! { dg-error "is type incompatible" } + +end subroutine implicit_test3 +! +! Allocation of a scalar with a type-spec specification without implicit none +! +subroutine implicit_test4 + + real, allocatable :: x + real(4), allocatable :: x4 + real(8), allocatable :: x8 + double precision, allocatable :: d1 + character, allocatable :: c1 + + type a + integer mytype + end type a + + type(a), allocatable :: b + + allocate(complex :: x) ! { dg-error "is type incompatible" } + allocate(real(8) :: x4) ! { dg-error "differs from the kind type parameter" } + allocate(real(4) :: x8) ! { dg-error "differs from the kind type parameter" } + allocate(double :: d1) ! { dg-error "not a nonprocedure pointer or an allocatable" } + allocate(character(:) :: c1) ! { dg-error "Syntax error in CHARACTER declaration" } + allocate(real :: b) ! { dg-error "is type incompatible" } + +end subroutine implicit_test4 Index: gcc/testsuite/gfortran.dg/allocate_derived_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/allocate_derived_1.f90 (revision 166091) +++ gcc/testsuite/gfortran.dg/allocate_derived_1.f90 (working copy) @@ -32,7 +32,6 @@ allocate(t1 :: x(2)) allocate(t2 :: x(3)) allocate(t3 :: x(4)) - allocate(tx :: x(5)) ! { dg-error "is not an accessible derived type" } allocate(u0 :: x(6)) ! { dg-error "may not be ABSTRACT" } allocate(v1 :: x(7)) ! { dg-error "is type incompatible with typespec" } Index: gcc/testsuite/gfortran.dg/select_type_1.f03 =================================================================== --- gcc/testsuite/gfortran.dg/select_type_1.f03 (revision 166091) +++ gcc/testsuite/gfortran.dg/select_type_1.f03 (working copy) @@ -45,7 +45,7 @@ print *,"a is TYPE(ts)" type is (t3) ! { dg-error "must be an extension of" } print *,"a is TYPE(t3)" - type is (t4) ! { dg-error "is not an accessible derived type" } + type is (t4) ! { dg-error "error in TYPE IS specification" } print *,"a is TYPE(t3)" class is (t1) print *,"a is CLASS(t1)" Index: gcc/fortran/match.c =================================================================== --- gcc/fortran/match.c (revision 166091) +++ gcc/fortran/match.c (working copy) @@ -2711,26 +2711,25 @@ gfc_free_alloc_list (gfc_alloc *p) static match match_derived_type_spec (gfc_typespec *ts) { + char name[GFC_MAX_SYMBOL_LEN + 1]; locus old_locus; gfc_symbol *derived; - old_locus = gfc_current_locus; + old_locus = gfc_current_locus; - if (gfc_match_symbol (&derived, 1) == MATCH_YES) + if (gfc_match ("%n", name) != MATCH_YES) { - if (derived->attr.flavor == FL_DERIVED) - { - ts->type = BT_DERIVED; - ts->u.derived = derived; - return MATCH_YES; - } - else - { - /* Enforce F03:C476. */ - gfc_error ("'%s' at %L is not an accessible derived type", - derived->name, &gfc_current_locus); - return MATCH_ERROR; - } + gfc_current_locus = old_locus; + return MATCH_NO; + } + + gfc_find_symbol (name, NULL, 1, &derived); + + if (derived && derived->attr.flavor == FL_DERIVED) + { + ts->type = BT_DERIVED; + ts->u.derived = derived; + return MATCH_YES; } gfc_current_locus = old_locus; @@ -2752,17 +2751,12 @@ match_type_spec (gfc_typespec *ts) locus old_locus; gfc_clear_ts (ts); - gfc_gobble_whitespace(); + gfc_gobble_whitespace (); old_locus = gfc_current_locus; - m = match_derived_type_spec (ts); - if (m == MATCH_YES) + if (match_derived_type_spec (ts) == MATCH_YES) { - old_locus = gfc_current_locus; - if (gfc_match (" :: ") != MATCH_YES) - return MATCH_ERROR; - gfc_current_locus = old_locus; - /* Enfore F03:C401. */ + /* Enforce F03:C401. */ if (ts->u.derived->attr.abstract) { gfc_error ("Derived type '%s' at %L may not be ABSTRACT", @@ -2771,10 +2765,6 @@ match_type_spec (gfc_typespec *ts) } return MATCH_YES; } - else if (m == MATCH_ERROR && gfc_match (" :: ") == MATCH_YES) - return MATCH_ERROR; - - gfc_current_locus = old_locus; if (gfc_match ("integer") == MATCH_YES) { @@ -2807,7 +2797,13 @@ match_type_spec (gfc_typespec *ts) if (gfc_match ("character") == MATCH_YES) { ts->type = BT_CHARACTER; - goto char_selector; + + m = gfc_match_char_spec (ts); + + if (m == MATCH_NO) + m = MATCH_YES; + + return m; } if (gfc_match ("logical") == MATCH_YES) @@ -2836,15 +2832,6 @@ kind_selector: m = MATCH_YES; /* No kind specifier found. */ return m; - -char_selector: - - m = gfc_match_char_spec (ts); - - if (m == MATCH_NO) - m = MATCH_YES; /* No kind specifier found. */ - - return m; } @@ -2957,8 +2944,8 @@ gfc_match_allocate (void) || sym->ns->proc_name->attr.proc_pointer); if (b1 && b2 && !b3) { - gfc_error ("Allocate-object at %C is not a nonprocedure pointer " - "or an allocatable variable"); + gfc_error ("Allocate-object at %L is not a nonprocedure pointer " + "or an allocatable variable", &tail->expr->where); goto cleanup; }