re PR fortran/14067 (no warning when character data statement overflows declared size)

2006-06-05  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/14067
	* data.c (create_character_intializer): Add warning message
	for truncated string.

	PR fortran/16943
	* symbol.c : Include flags.h.
	(gfc_add_type): If a procedure and types are the same do not
	throw an error unless standard is less than gnu or pedantic.

	PR fortran/20838
	* parse.c (parse_do_block): Error if named block do construct
	does not have a named enddo.

	PR fortran/27655
	* check.c (gfc_check_associated): Pick up EXPR_NULL for pointer
	as well as target and put error return at end of function.

2006-06-05  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/14067
	* gfortran.dg/data_char_1.f90: Add messages for truncated
	strings.

	PR fortran/16943
	* gfortran.dg/func_decl_2.f90: New test.

	PR fortran/20838
	* gfortran.dg/do_2.f90: New test.

	PR fortran/27655
	* gfortran.dg/associated_3.f90: New test.

From-SVN: r114385

10 files changed, 163 insertions, 13 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index cc040a6..abff6a2 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,22 @@
+2006-06-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/14067
+	* data.c (create_character_intializer): Add warning message
+	for truncated string.
+
+	PR fortran/16943
+	* symbol.c : Include flags.h.
+	(gfc_add_type): If a procedure and types are the same do not
+	throw an error unless standard is less than gnu or pedantic.
+
+	PR fortran/20838
+	* parse.c (parse_do_block): Error if named block do construct
+	does not have a named enddo.
+
+	PR fortran/27655
+	* check.c (gfc_check_associated): Pick up EXPR_NULL for pointer
+	as well as target and put error return at end of function.
+
 2006-06-03  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
 	* trans.c (gfc_msg_bounds, gfc_msg_fault, gfc_msg_wrong_return):
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index c68e59c..15278f4 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -499,11 +499,16 @@ gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
   symbol_attribute attr;
   int i;
   try t;
+  locus *where;
+
+  where = &pointer->where;
 
   if (pointer->expr_type == EXPR_VARIABLE)
     attr = gfc_variable_attr (pointer, NULL);
   else if (pointer->expr_type == EXPR_FUNCTION)
     attr = pointer->symtree->n.sym->attr;
+  else if (pointer->expr_type == EXPR_NULL)
+    goto null_arg;
   else
     gcc_assert (0); /* Pointer must be a variable or a function.  */
 
@@ -519,13 +524,9 @@ gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
   if (target == NULL)
     return SUCCESS;
 
+  where = &target->where;
   if (target->expr_type == EXPR_NULL)
-    {
-      gfc_error ("NULL pointer at %L is not permitted as actual argument "
-                 "of '%s' intrinsic function",
-                 &target->where, gfc_current_intrinsic);
-      return FAILURE;
-    }
+    goto null_arg;
 
   if (target->expr_type == EXPR_VARIABLE)
     attr = gfc_variable_attr (target, NULL);
@@ -565,6 +566,13 @@ gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
           }
     }
   return t;
+
+null_arg:
+
+  gfc_error ("NULL pointer at %L is not permitted as actual argument "
+	     "of '%s' intrinsic function", where, gfc_current_intrinsic);
+  return FAILURE;
+
 }
 
 
diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c
index 9f256bc..c708bec 100644
--- a/gcc/fortran/data.c
+++ b/gcc/fortran/data.c
@@ -185,7 +185,12 @@ create_character_intializer (gfc_expr * init, gfc_typespec * ts,
   /* Copy the initial value.  */
   len = rvalue->value.character.length;
   if (len > end - start)
-    len = end - start;
+    {
+      len = end - start;
+      gfc_warning_now ("initialization string truncated to match variable "
+		       "at %L", &rvalue->where);
+    }
+
   memcpy (&dest[start], rvalue->value.character.string, len);
 
   /* Pad with spaces.  Substrings will already be blanked.  */
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 70c92b7..5b98d1d 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -2282,6 +2282,15 @@ loop:
       break;
 
     case ST_IMPLIED_ENDDO:
+     /* If the do-stmt of this DO construct has a do-construct-name,
+	the corresponding end-do must be an end-do-stmt (with a matching
+	name, but in that case we must have seen ST_ENDDO first).
+	We only complain about this in pedantic mode.  */
+     if (gfc_current_block () != NULL)
+	gfc_error_now
+	  ("named block DO at %L requires matching ENDDO name",
+	   &gfc_current_block()->declared_at);
+
       break;
 
     default:
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 7acef42..63e45ec 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -23,6 +23,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
 
 #include "config.h"
 #include "system.h"
+#include "flags.h"
 #include "gfortran.h"
 #include "parse.h"
 
@@ -1178,9 +1179,18 @@ gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where)
 
   if (sym->ts.type != BT_UNKNOWN)
     {
-      gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
-		 where, gfc_basic_typename (sym->ts.type));
-      return FAILURE;
+      const char *msg = "Symbol '%s' at %L already has basic type of %s";
+      if (!(sym->ts.type == ts->type
+	     && (sym->attr.flavor == FL_PROCEDURE || sym->attr.result))
+	   || gfc_notification_std (GFC_STD_GNU) == ERROR
+	   || pedantic)
+	{
+	  gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
+	  return FAILURE;
+	}
+      else if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
+			       gfc_basic_typename (sym->ts.type)) == FAILURE)
+	  return FAILURE;
     }
 
   flavor = sym->attr.flavor;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 1396e30..a47d993 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,18 @@
+2006-06-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/14067
+	* gfortran.dg/data_char_1.f90: Add messages for truncated
+	strings.
+
+	PR fortran/16943
+	* gfortran.dg/func_decl_2.f90: New test.
+
+	PR fortran/20838
+	* gfortran.dg/do_2.f90: New test.
+
+	PR fortran/27655
+	* gfortran.dg/associated_3.f90: New test.
+
 2006-06-04  Mark Mitchell  <mark@codesourcery.com>
 
 	PR c++/27819
diff --git a/gcc/testsuite/gfortran.dg/associated_3.f90 b/gcc/testsuite/gfortran.dg/associated_3.f90
new file mode 100644
index 0000000..c0a7f9a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associated_3.f90
@@ -0,0 +1,8 @@
+! { dg-do compile }
+! Test for fix of PR27655
+!
+!Contributed by Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org> 
+  integer, pointer :: i
+  print *, associated(NULL(),i) ! { dg-error "not permitted as actual argument" }
+  print *, associated(i,NULL()) ! { dg-error "not permitted as actual argument" }
+end
diff --git a/gcc/testsuite/gfortran.dg/data_char_1.f90 b/gcc/testsuite/gfortran.dg/data_char_1.f90
index cce31af..00381c6 100644
--- a/gcc/testsuite/gfortran.dg/data_char_1.f90
+++ b/gcc/testsuite/gfortran.dg/data_char_1.f90
@@ -1,12 +1,13 @@
 ! { dg-do run }
 ! Test character variables in data statements
-! Also substrings of cahracter variables.
+! Also substrings of character variables.
 ! PR14976 PR16228 
 program data_char_1
   character(len=5) :: a(2)
   character(len=5) :: b(2)
-  data a /'Hellow', 'orld'/
-  data b(:)(1:4), b(1)(5:5), b(2)(5:5) /'abcdefg', 'hi', 'j', 'k'/
+  data a /'Hellow', 'orld'/       ! { dg-warning "string truncated" }
+  data b(:)(1:4), b(1)(5:5), b(2)(5:5) &
+      /'abcdefg', 'hi', 'j', 'k'/ ! { dg-warning "string truncated" }
   
   if ((a(1) .ne. 'Hello') .or. (a(2) .ne. 'orld ')) call abort
   if ((b(1) .ne. 'abcdj') .or. (b(2) .ne. 'hi  k')) call abort
diff --git a/gcc/testsuite/gfortran.dg/do_2.f90 b/gcc/testsuite/gfortran.dg/do_2.f90
new file mode 100644
index 0000000..95959d0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/do_2.f90
@@ -0,0 +1,54 @@
+! { dg-do compile }
+! Check the fix for PR20839, which concerned non-compliance with one of the
+! constraints for block-do-constructs (8.1.4.1.1):
+! Constraint: If the do-stmt of a block-do-construct is identified by a 
+! do-construct-name, the corresponding end-do shall be an end-do-stmt
+! specifying the same do-construct-name. (Tests a & b)
+! If the do-stmt of a block-do-construct is not identified by a
+! do-construct-name, the corresponding end-do shall not specify a
+! do-construct-name. (Tests c & d)
+! Constraint: If the do-stmt is a nonlabel-do-stmt, the corresponding end-do
+! shall be an end-do-stmt.
+! Constraint: If the do-stmt is a label-do-stmt, the corresponding end-do shall
+! be identified with the same label.
+!
+! Test a - this was the PR
+  doi: DO 111 i=1,3 ! { dg-error "requires matching ENDDO name" }
+111 continue 
+! Test b
+  doii: DO 112 ij=1,3
+112 enddo doij      ! { dg-error "Expected label" }
+! Test c
+  DO 113 ik=1,3
+113 enddo doik      ! { dg-error "Syntax error" }
+! Test d
+  DO il=1,3
+  enddo doil        ! { dg-error "Syntax error" }
+! Test e
+  doj: DO 114 j=1,3
+  enddo doj         ! { dg-error "doesn't match DO label" }
+
+! Correct block do constructs
+dok: DO 115 k=1,3
+    dokk: do kk=1,3
+        dokkk: DO
+                   do kkkk=1,3
+                       do
+                       enddo
+                   enddo
+	       enddo dokkk
+	  enddo dokk
+115  enddo dok 
+! Correct non-block do constructs
+  do 117 l=1,3
+      do ll=1,3
+          do 116 lll=1,3
+116       continue
+      enddo
+117 enddo
+! These prevent an EOF error, arising from the previous errors.
+end do
+113 end do
+112 end do doii
+END
+
diff --git a/gcc/testsuite/gfortran.dg/func_decl_2.f90 b/gcc/testsuite/gfortran.dg/func_decl_2.f90
new file mode 100644
index 0000000..c2cc440
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/func_decl_2.f90
@@ -0,0 +1,21 @@
+! { dg-do compile }
+! Test fix for PR16943 in which the double typing of
+! N caused an error.  This is a common extension to the
+! F95 standard, so the error is only thrown for -std=f95
+! or -pedantic.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+  program bug8 
+    implicit none 
+    stop " OK. " 
+
+  contains 
+
+    integer function bugf(M) result (N) 
+      integer, intent (in) :: M 
+      integer :: N ! { dg-warning "already has basic type of INTEGER" }
+      N = M 
+      return 
+    end function bugf
+  end program bug8