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

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

gcc/fortran/ChangeLog

+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

gcc/fortran/interface.c

@@ -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;
 	    }

gcc/fortran/resolve.c

@@ -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);

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/common_15.f90

+! { 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

gcc/testsuite/gfortran.dg/dummy_procedure_5.f90

+! { 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 

gcc/testsuite/gfortran.dg/interface_26.f90

@@ -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 ) 

gcc/testsuite/gfortran.dg/proc_ptr_11.f90

@@ -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
 

gcc/testsuite/gfortran.dg/proc_ptr_15.f90

@@ -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

gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90

@@ -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
 

gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90

@@ -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