procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/50515 (gfortran should not accept an external that is a common (r178939))

Browse source 
2011-09-26  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/50515
	* resolve.c (resolve_common_blocks): Check for EXTERNAL attribute.

	PR fortran/50517
	* interface.c (gfc_compare_interfaces): Bugfix in check for result type.


2011-09-26  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/50515
	* gfortran.dg/common_15.f90: New.

	PR fortran/50517
	* gfortran.dg/dummy_procedure_5.f90: New.
	* gfortran.dg/interface_26.f90: Modified error message.
	* gfortran.dg/proc_ptr_11.f90: Ditto.
	* gfortran.dg/proc_ptr_15.f90: Ditto.
	* gfortran.dg/proc_ptr_comp_20.f90: Ditto.
	* gfortran.dg/proc_ptr_result_5.f90: Ditto.

From-SVN: r179213
This commit is contained in:
Janus Weil 2011-09-26 22:05:43 +02:00
parent fbaec95026
commit ef71fdd925
11 changed files with 76 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View file

@ -1,3 +1,11 @@
2011-09-26 Janus Weil <janus@gcc.gnu.org>
PR fortran/50515
* resolve.c (resolve_common_blocks): Check for EXTERNAL attribute.
PR fortran/50517
* interface.c (gfc_compare_interfaces): Bugfix in check for result type.
2011-09-22 Janus Weil <janus@gcc.gnu.org>
PR fortran/41733

6
gcc/fortran/interface.c
View file

@ -1121,13 +1121,13 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
{
if (s1->attr.function && s2->attr.function)
{
/* If both are functions, check type and kind. */
/* If both are functions, check result type. */
if (s1->ts.type == BT_UNKNOWN)
return 1;
if ((s1->ts.type != s2->ts.type) || (s1->ts.kind != s2->ts.kind))
if (!compare_type_rank (s1,s2))
{
if (errmsg != NULL)
snprintf (errmsg, err_len, "Type/kind mismatch in return value "
snprintf (errmsg, err_len, "Type/rank mismatch in return value "
"of '%s'", name2);
return 0;
}

4
gcc/fortran/resolve.c
View file

@ -905,6 +905,10 @@ resolve_common_blocks (gfc_symtree *common_root)
gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
sym->name, &common_root->n.common->where, &sym->declared_at);
if (sym->attr.external)
gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
sym->name, &common_root->n.common->where);
if (sym->attr.intrinsic)
gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
sym->name, &common_root->n.common->where);

13
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,16 @@
2011-09-26 Janus Weil <janus@gcc.gnu.org>
PR fortran/50515
* gfortran.dg/common_15.f90: New.
PR fortran/50517
* gfortran.dg/dummy_procedure_5.f90: New.
* gfortran.dg/interface_26.f90: Modified error message.
* gfortran.dg/proc_ptr_11.f90: Ditto.
* gfortran.dg/proc_ptr_15.f90: Ditto.
* gfortran.dg/proc_ptr_comp_20.f90: Ditto.
* gfortran.dg/proc_ptr_result_5.f90: Ditto.
2011-09-26 Jason Merrill <jason@redhat.com>
PR c++/50512

9
gcc/testsuite/gfortran.dg/common_15.f90 Normal file
View file

@ -0,0 +1,9 @@
! { dg-do compile }
!
! PR 50515: gfortran should not accept an external that is a common (r178939)
!
! Contributed by Vittorio Zecca <zeccav@gmail.com>
common/sub/ a ! { dg-error "can not have the EXTERNAL attribute" }
external sub
end

26
gcc/testsuite/gfortran.dg/dummy_procedure_5.f90 Normal file
View file

@ -0,0 +1,26 @@
! { dg-do compile }
!
! PR 50517: gfortran must detect that actual argument type is different from dummy argument type (r178939)
!
! Contributed by Vittorio Zecca <zeccav@gmail.com>
program main
type t
integer g
end type
type u
integer g
end type
type(u), external :: ufunc
call sub(ufunc) ! { dg-error "Type/rank mismatch in return value" }
contains
subroutine sub(tfunc)
type(t), external :: tfunc
end subroutine
end program

2
gcc/testsuite/gfortran.dg/interface_26.f90
View file

@ -37,7 +37,7 @@ CONTAINS
END INTERFACE
INTEGER, EXTERNAL :: UserOp
res = UserFunction( a,b, UserOp ) ! { dg-error "Type/kind mismatch in return value" }
res = UserFunction( a,b, UserOp ) ! { dg-error "Type/rank mismatch in return value" }
if( res .lt. 10 ) then
res = recSum( a, res, UserFunction, UserOp )

6
gcc/testsuite/gfortran.dg/proc_ptr_11.f90
View file

@ -40,11 +40,11 @@ program bsp
p2 => p1
p1 => p2
p1 => abs ! { dg-error "Type/kind mismatch in return value" }
p2 => abs ! { dg-error "Type/kind mismatch in return value" }
p1 => abs ! { dg-error "Type/rank mismatch in return value" }
p2 => abs ! { dg-error "Type/rank mismatch in return value" }
p3 => dsin
p3 => sin ! { dg-error "Type/kind mismatch in return value" }
p3 => sin ! { dg-error "Type/rank mismatch in return value" }
contains

8
gcc/testsuite/gfortran.dg/proc_ptr_15.f90
View file

@ -19,10 +19,10 @@ p4 => p3
p6 => p1
! invalid
p1 => iabs ! { dg-error "Type/kind mismatch in return value" }
p1 => p2 ! { dg-error "Type/kind mismatch in return value" }
p1 => p5 ! { dg-error "Type/kind mismatch in return value" }
p6 => iabs ! { dg-error "Type/kind mismatch in return value" }
p1 => iabs ! { dg-error "Type/rank mismatch in return value" }
p1 => p2 ! { dg-error "Type/rank mismatch in return value" }
p1 => p5 ! { dg-error "Type/rank mismatch in return value" }
p6 => iabs ! { dg-error "Type/rank mismatch in return value" }
p4 => p2 ! { dg-error "is not a subroutine" }
contains

8
gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90
View file

@ -27,11 +27,11 @@ type(t2) :: o2
procedure(logical),pointer :: pp1
procedure(complex),pointer :: pp2
pp1 => pp2 ! { dg-error "Type/kind mismatch" }
pp2 => o2%ppc ! { dg-error "Type/kind mismatch" }
pp1 => pp2 ! { dg-error "Type/rank mismatch" }
pp2 => o2%ppc ! { dg-error "Type/rank mismatch" }
o1%ppc => pp1 ! { dg-error "Type/kind mismatch" }
o1%ppc => o2%ppc ! { dg-error "Type/kind mismatch" }
o1%ppc => pp1 ! { dg-error "Type/rank mismatch" }
o1%ppc => o2%ppc ! { dg-error "Type/rank mismatch" }
contains

2
gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90
View file

@ -6,7 +6,7 @@
program test
procedure(real), pointer :: p
p => f() ! { dg-error "Type/kind mismatch in return value" }
p => f() ! { dg-error "Type/rank mismatch in return value" }
contains
function f()
pointer :: f