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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@114385 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index cc040a6..abff6a2 100644 (file)
--- 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):
 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 (file)
--- 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;
   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;
 
   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.  */
 
   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;
 
   if (target == NULL)
     return SUCCESS;
 

+  where = &target->where;

   if (target->expr_type == EXPR_NULL)
   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);
 
   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;
           }
     }
   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 (file)
--- 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)
   /* 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.  */
   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 (file)
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -2282,6 +2282,15 @@ loop:
       break;
 
     case ST_IMPLIED_ENDDO:
       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:
       break;
 
     default:

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 7acef42..63e45ec 100644 (file)
--- 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 "config.h"
 #include "system.h"

+#include "flags.h"

 #include "gfortran.h"
 #include "parse.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)
     {
 
   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;
     }
 
   flavor = sym->attr.flavor;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 1396e30..a47d993 100644 (file)
--- 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
 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 (file)
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 (file)
--- 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
 ! { 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)
 ! 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
   
   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 (file)
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 (file)
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