2008-09-18 Basile Starynkevitch <basile@starynkevitch.net>

	MELT branch merged with trunk r140490




git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@140495 138bc75d-0d04-0410-961f-82ee72b054a4

11 files changed, 593 insertions, 3 deletions

diff --git a/gcc/testsuite/gfortran.dg/access_spec_3.f90 b/gcc/testsuite/gfortran.dg/access_spec_3.f90
new file mode 100644
index 00000000000..9a076b66c54
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/access_spec_3.f90
@@ -0,0 +1,34 @@
+! { dg-do compile }
+!
+! Tests the fix for PR36454, where the PUBLIC declaration for
+! aint and bint was rejected because the access was already set.
+!
+! Contributed by Thomas Orgis <thomas.orgis@awi.de>
+
+module base
+        integer :: baseint
+end module
+
+module a
+        use base, ONLY: aint => baseint
+end module
+
+module b
+        use base, ONLY: bint => baseint
+end module
+
+module c
+        use a
+        use b
+        private
+        public :: aint, bint
+end module
+
+program user
+        use c, ONLY: aint, bint
+
+        aint = 3
+        bint = 8
+        write(*,*) aint
+end program
+! { dg-final { cleanup-modules "base a b c" } }
diff --git a/gcc/testsuite/gfortran.dg/allocate_error_1.f90 b/gcc/testsuite/gfortran.dg/allocate_error_1.f90
new file mode 100644
index 00000000000..42a12159e28
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_error_1.f90
@@ -0,0 +1,14 @@
+! { dg-do run }
+! { dg-shouldfail "runtime error" }
+! { dg-output "At line 13.*Attempting to allocate .* 'arr'" }
+
+! PR fortran/37507
+! Check that locus is printed for ALLOCATE errors.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER, ALLOCATABLE :: arr(:)
+
+  ALLOCATE (arr(5))
+  ALLOCATE (arr(6))
+END PROGRAM main
diff --git a/gcc/testsuite/gfortran.dg/ambiguous_specific_2.f90 b/gcc/testsuite/gfortran.dg/ambiguous_specific_2.f90
new file mode 100644
index 00000000000..4597b3c8630
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ambiguous_specific_2.f90
@@ -0,0 +1,42 @@
+! { dg-do compile }
+! Checks the fix for PR33542 does not throw an error if there is no
+! ambiguity in the specific interfaces of foo.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+MODULE M1
+   INTERFACE FOO
+     MODULE PROCEDURE FOO
+   END INTERFACE
+CONTAINS
+   SUBROUTINE FOO(I)
+     INTEGER, INTENT(IN) :: I
+     WRITE(*,*) 'INTEGER'
+   END SUBROUTINE FOO
+END MODULE M1
+
+MODULE M2
+   INTERFACE FOO
+     MODULE PROCEDURE FOOFOO
+   END INTERFACE
+CONTAINS
+   SUBROUTINE FOOFOO(R)
+     REAL, INTENT(IN) :: R
+     WRITE(*,*) 'REAL'
+   END SUBROUTINE FOOFOO
+END MODULE M2
+
+PROGRAM P
+   USE M1
+   USE M2
+   implicit none
+   external bar
+   CALL FOO(10)
+   CALL FOO(10.)
+   call bar (foo) 
+END PROGRAM P
+
+SUBROUTINE bar (arg)
+  EXTERNAL arg
+END SUBROUTINE bar
+! { dg-final { cleanup-modules "m1 m2" } }
diff --git a/gcc/testsuite/gfortran.dg/deallocate_error_1.f90 b/gcc/testsuite/gfortran.dg/deallocate_error_1.f90
new file mode 100644
index 00000000000..98ffdb3b91a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/deallocate_error_1.f90
@@ -0,0 +1,15 @@
+! { dg-do run }
+! { dg-shouldfail "runtime error" }
+! { dg-output "At line 14.*Attempt to DEALLOCATE unallocated 'arr'" }
+
+! PR fortran/37507
+! Check that locus is printed for DEALLOCATE errors.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER, ALLOCATABLE :: arr(:)
+
+  ALLOCATE (arr(5))
+  DEALLOCATE (arr)
+  DEALLOCATE (arr)
+END PROGRAM main
diff --git a/gcc/testsuite/gfortran.dg/deallocate_error_2.f90 b/gcc/testsuite/gfortran.dg/deallocate_error_2.f90
new file mode 100644
index 00000000000..bda1adff514
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/deallocate_error_2.f90
@@ -0,0 +1,16 @@
+! { dg-do run }
+! { dg-shouldfail "runtime error" }
+! { dg-output "At line 15.*Attempt to DEALLOCATE unallocated 'ptr'" }
+
+! PR fortran/37507
+! Check that locus is printed for DEALLOCATE errors.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER, POINTER :: ptr
+  INTEGER, ALLOCATABLE :: arr(:)
+
+  ALLOCATE (ptr, arr(5))
+  DEALLOCATE (ptr)
+  DEALLOCATE (arr, ptr)
+END PROGRAM main
diff --git a/gcc/testsuite/gfortran.dg/generic_17.f90 b/gcc/testsuite/gfortran.dg/generic_17.f90
new file mode 100644
index 00000000000..968d9c10c37
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/generic_17.f90
@@ -0,0 +1,40 @@
+! { dg-do compile }
+! Test the patch for PR36374 in which the different
+! symbols for 'foobar' would be incorrectly flagged as
+! ambiguous in foo_mod.
+!
+! Contributed by Salvatore Filippone  <sfilippone@uniroma2.it>
+!
+module s_foo_mod

+  type s_foo_type

+    real(kind(1.e0)) :: v

+  end type s_foo_type

+  interface foobar

+    subroutine s_foobar(x)

+      import 

+      type(s_foo_type), intent (inout) :: x

+    end subroutine s_foobar

+  end interface

+end module s_foo_mod

+

+module d_foo_mod

+  type d_foo_type

+    real(kind(1.d0)) :: v

+  end type d_foo_type

+  interface foobar

+    subroutine d_foobar(x)

+      import  

+      type(d_foo_type), intent (inout) :: x

+    end subroutine d_foobar

+  end interface

+end module d_foo_mod

+

+module foo_mod

+  use s_foo_mod

+  use d_foo_mod

+end module foo_mod

+

+subroutine s_foobar(x)  

+  use foo_mod

+end subroutine s_foobar

+! { dg-final { cleanup-modules "s_foo_mod d_foo_mod foo_mod" } }
diff --git a/gcc/testsuite/gfortran.dg/generic_actual_arg.f90 b/gcc/testsuite/gfortran.dg/generic_actual_arg.f90
index 978f64d0951..9cf0d8eb004 100644
--- a/gcc/testsuite/gfortran.dg/generic_actual_arg.f90
+++ b/gcc/testsuite/gfortran.dg/generic_actual_arg.f90
@@ -2,11 +2,14 @@
 ! Tests fix for PR20886 in which the passing of a generic procedure as
 ! an actual argument was not detected.
 !
+! The second module and the check that CALCULATION2 is a good actual
+! argument was added following the fix for PR26374.
+!
 ! Contributed by Joost VandeVondele  <jv244@cam.ac.uk> 
 !
 MODULE TEST
 INTERFACE CALCULATION
-  MODULE PROCEDURE C1,C2
+  MODULE PROCEDURE C1, C2
 END INTERFACE
 CONTAINS
 SUBROUTINE C1(r)
@@ -16,11 +19,27 @@ SUBROUTINE C2(r)
  REAL :: r
 END SUBROUTINE
 END MODULE TEST
+
+MODULE TEST2
+INTERFACE CALCULATION2
+  MODULE PROCEDURE CALCULATION2, C3
+END INTERFACE
+CONTAINS
+SUBROUTINE CALCULATION2(r)
+ INTEGER :: r
+END SUBROUTINE
+SUBROUTINE C3(r)
+ REAL :: r
+END SUBROUTINE
+END MODULE TEST2
     
 USE TEST
-CALL F(CALCULATION) ! { dg-error "GENERIC procedure" } 
+USE TEST2
+CALL F(CALCULATION)  ! { dg-error "GENERIC procedure" } 
+
+CALL F(CALCULATION2) ! OK because there is a same name specific 
 END
 
 SUBROUTINE F()
 END SUBROUTINE
-! { dg-final { cleanup-modules "TEST" } }
+! { dg-final { cleanup-modules "TEST TEST2" } }
diff --git a/gcc/testsuite/gfortran.dg/host_assoc_call_2.f90 b/gcc/testsuite/gfortran.dg/host_assoc_call_2.f90
new file mode 100644
index 00000000000..a74f37343bb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/host_assoc_call_2.f90
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! Tests the fix for PR36700, in which the call to the function would
+! cause an ICE.
+!
+! Contributed by <terry@chem.gu.se>
+!
+module Diatoms
+  implicit none
+contains
+  function InitialDiatomicX () result(v4)    ! { dg-error "has a type" }
+    real(kind = 8), dimension(4) :: v4
+    v4 = 1
+  end function InitialDiatomicX
+  subroutine FindDiatomicPeriod
+    call InitialDiatomicX ()    ! { dg-error "which is not consistent with the CALL" }
+  end subroutine FindDiatomicPeriod
+end module Diatoms
+! { dg-final { cleanup-modules "Diatoms" } }
diff --git a/gcc/testsuite/gfortran.dg/host_assoc_types_2.f90 b/gcc/testsuite/gfortran.dg/host_assoc_types_2.f90
new file mode 100644
index 00000000000..824a4959217
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/host_assoc_types_2.f90
@@ -0,0 +1,69 @@
+! { dg-do compile }
+! Tests the fix for PR33945, the host association of overloaded_type_s
+! would be incorrectly blocked by the use associated overloaded_type.
+!
+! Contributed by Jonathan Hogg  <J.Hogg@rl.ac.uk>
+!
+module dtype

+   implicit none

+

+   type overloaded_type

+      double precision :: part

+   end type

+

+   interface overloaded_sub

+      module procedure overloaded_sub_d

+   end interface

+

+contains

+   subroutine overloaded_sub_d(otype)

+      type(overloaded_type), intent(in) :: otype

+

+      print *, "d type = ", otype%part

+   end subroutine

+end module

+

+module stype

+   implicit none

+

+   type overloaded_type

+      real :: part

+   end type

+

+   interface overloaded_sub

+      module procedure overloaded_sub_s

+   end interface

+

+contains

+   subroutine overloaded_sub_s(otype)

+      type(overloaded_type), intent(in) :: otype

+

+      print *, "s type = ", otype%part

+   end subroutine

+end module

+

+program test

+   use stype, overloaded_type_s => overloaded_type

+   use dtype, overloaded_type_d => overloaded_type

+   implicit none

+

+   type(overloaded_type_s) :: sval

+   type(overloaded_type_d) :: dval

+

+   sval%part = 1

+   dval%part = 2

+

+   call fred(sval, dval)

+

+contains

+   subroutine fred(sval, dval)

+      use stype

+

+      type(overloaded_type_s), intent(in) :: sval  ! This caused an error

+      type(overloaded_type_d), intent(in) :: dval

+

+      call overloaded_sub(sval)

+      call overloaded_sub(dval)

+   end subroutine

+end program

+! { dg-final { cleanup-modules "stype dtype" } }

diff --git a/gcc/testsuite/gfortran.dg/used_types_22.f90 b/gcc/testsuite/gfortran.dg/used_types_22.f90
new file mode 100644
index 00000000000..2a5ae451a3d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/used_types_22.f90
@@ -0,0 +1,294 @@
+! { dg-do compile }
+! Tests the fix for PR37274 a regression in which the derived type,
+! 'vector' of the function results contained in 'class_motion' is
+! private and is incorrectly detected to be ambiguous in 'smooth_mesh'.
+!
+! Contributed by Salvatore Filippone  <sfilippone@uniroma2.it>
+!
+module class_vector

+

+  implicit none

+

+  private ! Default

+  public :: vector                                  

+  public :: vector_ 

+

+  type vector

+     private

+     real(kind(1.d0)) :: x

+     real(kind(1.d0)) :: y

+     real(kind(1.d0)) :: z

+  end type vector

+

+contains

+  ! ----- Constructors -----

+

+  ! Public default constructor

+  elemental function vector_(x,y,z)

+    type(vector) :: vector_

+    real(kind(1.d0)), intent(in) :: x, y, z

+

+    vector_ = vector(x,y,z)

+

+  end function vector_

+

+end module class_vector

+

+module class_dimensions

+

+  implicit none

+

+  private ! Default

+  public :: dimensions

+

+  type dimensions

+     private

+     integer :: l

+     integer :: m

+     integer :: t

+     integer :: theta

+  end type dimensions

+

+

+end module class_dimensions

+

+module tools_math

+

+  implicit none

+

+

+  interface lin_interp

+     function lin_interp_s(f1,f2,fac)

+       real(kind(1.d0)) :: lin_interp_s

+       real(kind(1.d0)), intent(in) :: f1, f2

+       real(kind(1.d0)), intent(in) :: fac

+     end function lin_interp_s

+

+     function lin_interp_v(f1,f2,fac)

+       use class_vector

+       type(vector) :: lin_interp_v

+       type(vector),     intent(in) :: f1, f2

+       real(kind(1.d0)), intent(in) :: fac

+     end function lin_interp_v

+  end interface

+

+

+  interface pwl_deriv

+     subroutine pwl_deriv_x_s(dydx,x,y_data,x_data)

+       real(kind(1.d0)), intent(out) :: dydx

+       real(kind(1.d0)), intent(in) :: x

+       real(kind(1.d0)), intent(in) :: y_data(:)

+       real(kind(1.d0)), intent(in) :: x_data(:)

+     end subroutine pwl_deriv_x_s

+

+     subroutine pwl_deriv_x_v(dydx,x,y_data,x_data)

+       real(kind(1.d0)), intent(out) :: dydx(:)

+       real(kind(1.d0)), intent(in) :: x

+       real(kind(1.d0)), intent(in) :: y_data(:,:)

+       real(kind(1.d0)), intent(in) :: x_data(:)

+     end subroutine pwl_deriv_x_v

+

+     subroutine pwl_deriv_x_vec(dydx,x,y_data,x_data)

+       use class_vector

+       type(vector), intent(out) :: dydx

+       real(kind(1.d0)), intent(in) :: x

+       type(vector), intent(in) :: y_data(:)

+       real(kind(1.d0)), intent(in) :: x_data(:)

+     end subroutine pwl_deriv_x_vec

+  end interface

+

+end module tools_math

+

+module class_motion

+

+  use class_vector

+ 

+  implicit none

+  

+  private 

+  public :: motion 

+  public :: get_displacement, get_velocity

+

+  type motion

+     private

+     integer :: surface_motion

+     integer :: vertex_motion

+     !

+     integer :: iml

+     real(kind(1.d0)), allocatable :: law_x(:) 

+     type(vector), allocatable :: law_y(:)  

+  end type motion

+

+contains

+

+

+  function get_displacement(mot,x1,x2)

+    use tools_math

+

+    type(vector) :: get_displacement

+    type(motion), intent(in) :: mot

+    real(kind(1.d0)), intent(in) :: x1, x2

+    !

+    integer :: i1, i2, i3, i4

+    type(vector) :: p1, p2, v_A, v_B, v_C, v_D

+    type(vector) :: i_trap_1, i_trap_2, i_trap_3

+

+    get_displacement = vector_(0.d0,0.d0,0.d0)

+    

+  end function get_displacement

+

+

+  function get_velocity(mot,x)

+    use tools_math

+

+    type(vector) :: get_velocity

+    type(motion), intent(in) :: mot

+    real(kind(1.d0)), intent(in) :: x

+    !

+    type(vector) :: v

+    

+    get_velocity = vector_(0.d0,0.d0,0.d0)

+    

+  end function get_velocity

+  

+  

+

+end module class_motion

+

+module class_bc_math

+  

+  implicit none

+

+  private 

+  public :: bc_math                           

+

+  type bc_math

+     private

+     integer :: id

+     integer :: nbf

+     real(kind(1.d0)), allocatable :: a(:) 

+     real(kind(1.d0)), allocatable :: b(:) 

+     real(kind(1.d0)), allocatable :: c(:) 

+  end type bc_math

+

+  

+end module class_bc_math

+

+module class_bc

+

+  use class_bc_math

+  use class_motion

+

+  implicit none

+

+  private 

+  public :: bc_poly                          

+  public :: get_abc, &

+       &    get_displacement, get_velocity  

+

+  type bc_poly

+     private

+     integer :: id

+     type(motion) :: mot

+     type(bc_math), pointer :: math => null()

+  end type bc_poly

+

+

+  interface get_displacement

+     module procedure get_displacement, get_bc_motion_displacement

+  end interface

+

+  interface get_velocity

+     module procedure get_velocity, get_bc_motion_velocity

+  end interface

+

+  interface get_abc

+     module procedure get_abc_s, get_abc_v

+  end interface

+  

+contains

+

+

+  subroutine get_abc_s(bc,dim,id,a,b,c)

+    use class_dimensions

+    

+    type(bc_poly), intent(in) :: bc

+    type(dimensions), intent(in) :: dim

+    integer, intent(out) :: id

+    real(kind(1.d0)), intent(inout) :: a(:)

+    real(kind(1.d0)), intent(inout) :: b(:)

+    real(kind(1.d0)), intent(inout) :: c(:)

+    

+    

+  end subroutine get_abc_s

+

+

+  subroutine get_abc_v(bc,dim,id,a,b,c)

+    use class_dimensions

+    use class_vector

+

+    type(bc_poly), intent(in) :: bc

+    type(dimensions), intent(in) :: dim

+    integer, intent(out) :: id

+    real(kind(1.d0)), intent(inout) :: a(:)

+    real(kind(1.d0)), intent(inout) :: b(:)

+    type(vector),     intent(inout) :: c(:)

+

+    

+  end subroutine get_abc_v

+

+

+

+  function get_bc_motion_displacement(bc,x1,x2)result(res)

+    use class_vector

+    type(vector) :: res

+    type(bc_poly), intent(in) :: bc

+    real(kind(1.d0)), intent(in) :: x1, x2

+    

+    res = get_displacement(bc%mot,x1,x2)

+

+  end function get_bc_motion_displacement

+

+

+  function get_bc_motion_velocity(bc,x)result(res)

+    use class_vector

+    type(vector) :: res

+    type(bc_poly), intent(in) :: bc

+    real(kind(1.d0)), intent(in) :: x

+

+    res = get_velocity(bc%mot,x)

+

+  end function get_bc_motion_velocity

+

+

+end module class_bc

+

+module tools_mesh_basics

+  

+  implicit none

+  

+  interface

+     function geom_tet_center(v1,v2,v3,v4)

+       use class_vector

+       type(vector) :: geom_tet_center

+       type(vector), intent(in) :: v1, v2, v3, v4

+     end function geom_tet_center

+  end interface

+

+

+end module tools_mesh_basics

+

+

+subroutine smooth_mesh

+

+  use class_bc

+  use class_vector

+  use tools_mesh_basics

+

+  implicit none

+

+  type(vector) :: new_pos  ! the new vertex position, after smoothing

+

+end subroutine smooth_mesh

+! { dg-final { cleanup-modules "class_vector class_dimensions tools_math" } }
+! { dg-final { cleanup-modules "class_motion class_bc_math class_bc tools_mesh_basics" } }
diff --git a/gcc/testsuite/gfortran.dg/used_types_23.f90 b/gcc/testsuite/gfortran.dg/used_types_23.f90
new file mode 100644
index 00000000000..7374223693f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/used_types_23.f90
@@ -0,0 +1,29 @@
+! { dg-do compile }
+! Tests the fix for PR37274 comment 4 in which the use associated 'vector' was

+! passed up from the interface to the module 'tools_math'.
+!
+! Contributed by Mikael Morin  <mikael.morin@tele2.fr>
+!
+module class_vector

+  implicit none

+  type vector

+  end type vector

+end module class_vector

+

+module tools_math

+  implicit none

+  interface lin_interp

+     function lin_interp_v()

+       use class_vector

+       type(vector) :: lin_interp_v

+     end function lin_interp_v

+  end interface

+end module tools_math

+

+module smooth_mesh

+  use tools_math

+  implicit none

+  type(vector ) :: new_pos  ! { dg-error "used before it is defined" }

+end module smooth_mesh

+

+! { dg-final { cleanup-modules "class_vector tools_math smooth_mesh" } }