[Patch,Fortran] PR40823 - fix location of SUBROUTINE declaration

[Tobias Burnus <burnus at net-b dot de>]

Currently, the gfc_symbol for a SUBROUTINE gets as declared_at locus the
first occurrance. For module procedures this can be a PRIVATE/PUBLIC
statement or the usage in an INTERFACE as (MODULE) PROCEDURE or in a
type-bound PROCEDURE.

Having the locus at a PUBLIC statement gives strange results when doing
debugging/performance analysis as computing time is then assigned to the
PUBLIC line, which does not make much sense.

Besides debugging symbols, for some error message it makes more sense to
have them in the SUBROUTINE line rather than having:

PUBLIC ::  sub
                   ^
ERROR: Pure subroutine cannot have '*' argument.

For other errors, the PUBLIC or PROCEDURE line could be more helpful.
Still, I think it makes sense to move the locus as the attached patch does.

Build and regtested on x86-64-linux.
OK for the trunk?

Tobias

2010-02-09  Joost VandeVondele <jv244@cam.ac.uk>
	    Tobias Burnus <burnus@net-b.de>

	PR fortran/40823
	* decl.c (gfc_match_subroutine): Explicitly set sym->declared_at.

2010-02-09  Tobias Burnus <burnus@net-b.de>

	PR fortran/40823
	* gfortran.dg/private_type_1.f90: Update error location.
	* gfortran.dg/invalid_interface_assignment.f90: Ditto.
	* gfortran.dg/typebound_operator_2.f03: Ditto.
	* gfortran.dg/assignment_2.f90: Ditto.
	* gfortran.dg/redefined_intrinsic_assignment.f90: Ditto.
	* gfortran.dg/binding_label_tests_9.f03: Ditto.

Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 156656)
+++ gcc/fortran/decl.c	(working copy)
@@ -1,5 +1,5 @@
 /* Declaration statement matcher
-   Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009
+   Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
@@ -5100,6 +5100,10 @@ gfc_match_subroutine (void)
   if (get_proc_name (name, &sym, false))
     return MATCH_ERROR;
 
+  /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
+     the symbol existed before. */
+  sym->declared_at = gfc_current_locus;
+
   if (add_hidden_procptr_result (sym) == SUCCESS)
     sym = sym->result;
 
Index: gcc/testsuite/gfortran.dg/private_type_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/private_type_1.f90	(revision 156656)
+++ gcc/testsuite/gfortran.dg/private_type_1.f90	(working copy)
@@ -6,12 +6,12 @@
 module modboom
   implicit none
   private
-  public:: dummysub ! { dg-error "PRIVATE type and cannot be a dummy argument" }
+  public:: dummysub
   type:: intwrapper
     integer n
   end type intwrapper
 contains
-  subroutine dummysub(size, arg_array)
+  subroutine dummysub(size, arg_array) ! { dg-error "PRIVATE type and cannot be a dummy argument" }
    type(intwrapper) :: size
    real, dimension(size%n) :: arg_array
    real :: local_array(4)
Index: gcc/testsuite/gfortran.dg/invalid_interface_assignment.f90
===================================================================
--- gcc/testsuite/gfortran.dg/invalid_interface_assignment.f90	(revision 156656)
+++ gcc/testsuite/gfortran.dg/invalid_interface_assignment.f90	(working copy)
@@ -9,10 +9,10 @@ MODULE TT
    INTEGER :: I
  END TYPE data_type
  INTERFACE ASSIGNMENT (=)
-   MODULE PROCEDURE set   ! { dg-error "Alternate return cannot appear" }
+   MODULE PROCEDURE set
  END INTERFACE
 CONTAINS
-  PURE SUBROUTINE set(x1,*)
+  PURE SUBROUTINE set(x1,*) ! { dg-error "Alternate return cannot appear" }
     TYPE(data_type), INTENT(OUT) :: x1
     x1%i=0
   END SUBROUTINE set
Index: gcc/testsuite/gfortran.dg/typebound_operator_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_operator_2.f03	(revision 156656)
+++ gcc/testsuite/gfortran.dg/typebound_operator_2.f03	(working copy)
@@ -14,7 +14,7 @@ MODULE m
     PROCEDURE, NOPASS :: nopassed => onearg
     PROCEDURE, PASS :: threearg
     PROCEDURE, PASS :: sub
-    PROCEDURE, PASS :: sub2 ! { dg-error "must be a FUNCTION" }
+    PROCEDURE, PASS :: sub2
     PROCEDURE, PASS :: func
 
     ! These give errors at the targets' definitions.
@@ -57,7 +57,7 @@ CONTAINS
     CLASS(t), INTENT(IN) :: a
   END SUBROUTINE sub
 
-  SUBROUTINE sub2 (a, x)
+  SUBROUTINE sub2 (a, x) ! { dg-error "must be a FUNCTION" }
     CLASS(t), INTENT(IN) :: a
     INTEGER, INTENT(IN) :: x
   END SUBROUTINE sub2
Index: gcc/testsuite/gfortran.dg/assignment_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/assignment_2.f90	(revision 156656)
+++ gcc/testsuite/gfortran.dg/assignment_2.f90	(working copy)
@@ -38,10 +38,10 @@ end module m2
 
 MODULE m3
           INTERFACE ASSIGNMENT(=)
-             module procedure s ! { dg-error "must not redefine an INTRINSIC type" }
+             module procedure s
           END Interface
 contains
-             SUBROUTINE s(a,b)
+             SUBROUTINE s(a,b) ! { dg-error "must not redefine an INTRINSIC type" }
                  REAL,INTENT(OUT),VOLATILE :: a(1,*)
                  REAL,INTENT(IN) :: b(:,:)
              END SUBROUTINE
Index: gcc/testsuite/gfortran.dg/redefined_intrinsic_assignment.f90
===================================================================
--- gcc/testsuite/gfortran.dg/redefined_intrinsic_assignment.f90	(revision 156656)
+++ gcc/testsuite/gfortran.dg/redefined_intrinsic_assignment.f90	(working copy)
@@ -7,10 +7,10 @@
 MODULE M1
  IMPLICIT NONE
  INTERFACE ASSIGNMENT(=)
-  MODULE PROCEDURE T1 ! { dg-error "redefine an INTRINSIC type assignment" }
+  MODULE PROCEDURE T1
  END INTERFACE
 CONTAINS
- SUBROUTINE T1(I,J)
+ SUBROUTINE T1(I,J) ! { dg-error "redefine an INTRINSIC type assignment" }
    INTEGER, INTENT(OUT)  :: I
    INTEGER, INTENT(IN)  :: J
    I=-J
Index: gcc/testsuite/gfortran.dg/binding_label_tests_9.f03
===================================================================
--- gcc/testsuite/gfortran.dg/binding_label_tests_9.f03	(revision 156656)
+++ gcc/testsuite/gfortran.dg/binding_label_tests_9.f03	(working copy)
@@ -2,18 +2,18 @@
 module x
   use iso_c_binding
   implicit none
-  private :: bar ! { dg-warning "PRIVATE but has been given the binding label" }
+  private :: bar
   private :: my_private_sub
-  private :: my_private_sub_2 ! { dg-warning "PRIVATE but has been given the binding label" }
+  private :: my_private_sub_2
   public :: my_public_sub
 contains
-  subroutine bar() bind(c,name="foo") 
+  subroutine bar() bind(c,name="foo") ! { dg-warning "PRIVATE but has been given the binding label" }
   end subroutine bar
   
   subroutine my_private_sub() bind(c, name="")
   end subroutine my_private_sub
 
-  subroutine my_private_sub_2() bind(c) 
+  subroutine my_private_sub_2() bind(c) ! { dg-warning "PRIVATE but has been given the binding label" }
   end subroutine my_private_sub_2
 
   subroutine my_public_sub() bind(c, name="my_sub")