Re: [Patch, fortran] PR14067, PR16943, PR20838 and PR27655 - miscellaneous small fixes

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

Thanks, Stephen!

> :ADDPATCH fortran:
>
> Please accept four patches for the price of one.  They are all small 
> and are self explanatory.  The last has been seen before and was 
> agreed, in principle, with Steve Kargl, off list.  I relented and 
> provided a testcase for it though!
>
> Briefly:
>
> PR14067 - At present an overlong string in an initialization 
> expression is quietly truncated.  This patch adds a warning that this 
> is being done.
> PR16943 - This permits a common extension, for -std=gnu;
>             integer function foobar () result (n)
>             integer :: n
> PR20838 - At present, gfortran allows a named and labelled 
> do-block-construct to have and end-do without a name.  For obvious 
> reasons, this is subject to a constraint, which insists on a matching 
> name.  Stephen Bosscher posted a patch for this, which was OK but I 
> removed the -pedantic requirement.
> PR27655 - The patch throws an error if the pointer actual argument to 
> ASSOCIATED is NULL.
>
> 'Twixt the testcases and the ChangeLog entries, these patches should 
> be comprehensible.
>
> Regtested on FC5/Athlon.  OK for patch and 4.1?
>
> Paul
>
>
> 2006-05-26  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-05-26  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.

Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c	(revision 114326)
--- gcc/fortran/symbol.c	(working copy)
*************** Software Foundation, 51 Franklin Street,
*** 23,28 ****
--- 23,29 ----
  
  #include "config.h"
  #include "system.h"
+ #include "flags.h"
  #include "gfortran.h"
  #include "parse.h"
  
*************** gfc_add_type (gfc_symbol * sym, gfc_type
*** 1178,1186 ****
  
    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;
      }
  
    flavor = sym->attr.flavor;
--- 1179,1193 ----
  
    if (sym->ts.type != BT_UNKNOWN)
      {
!       if (!(sym->ts.type == ts->type
! 	     && (sym->attr.flavor == FL_PROCEDURE || sym->attr.result))
! 	   || gfc_notification_std (GFC_STD_GNU) == ERROR
! 	   || pedantic)
! 	{
! 	  gfc_error ("Symbol '%s' at %L already has basic type of %s",
! 		     sym->name, where, gfc_basic_typename (sym->ts.type));
! 	  return FAILURE;
! 	}
      }
  
    flavor = sym->attr.flavor;
Index: gcc/fortran/data.c
===================================================================
*** gcc/fortran/data.c	(revision 114326)
--- gcc/fortran/data.c	(working copy)
*************** create_character_intializer (gfc_expr * 
*** 185,191 ****
    /* Copy the initial value.  */
    len = rvalue->value.character.length;
    if (len > end - start)
!     len = end - start;
    memcpy (&dest[start], rvalue->value.character.string, len);
  
    /* Pad with spaces.  Substrings will already be blanked.  */
--- 185,196 ----
    /* Copy the initial value.  */
    len = rvalue->value.character.length;
    if (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.  */
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c	(revision 114326)
--- gcc/fortran/parse.c	(working copy)
*************** loop:
*** 2282,2287 ****
--- 2282,2296 ----
        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:
Index: gcc/fortran/check.c
===================================================================
*** gcc/fortran/check.c	(revision 114326)
--- gcc/fortran/check.c	(working copy)
*************** gfc_check_associated (gfc_expr * pointer
*** 499,509 ****
--- 499,514 ----
    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.  */
  
*************** gfc_check_associated (gfc_expr * pointer
*** 519,531 ****
    if (target == NULL)
      return SUCCESS;
  
    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;
!     }
  
    if (target->expr_type == EXPR_VARIABLE)
      attr = gfc_variable_attr (target, NULL);
--- 524,532 ----
    if (target == NULL)
      return SUCCESS;
  
+   where = &target->where;
    if (target->expr_type == EXPR_NULL)
!     goto null_arg;
  
    if (target->expr_type == EXPR_VARIABLE)
      attr = gfc_variable_attr (target, NULL);
*************** gfc_check_associated (gfc_expr * pointer
*** 565,570 ****
--- 566,578 ----
            }
      }
    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;
+ 
  }
  
  
Index: gcc/testsuite/gfortran.dg/associated_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/associated_3.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/associated_3.f90	(revision 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
Index: gcc/testsuite/gfortran.dg/func_decl_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/func_decl_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/func_decl_2.f90	(revision 0)
***************
*** 0 ****
--- 1,22 ----
+ ! { dg-do compile }
+ ! { dg-options "-std=gnu" }
+ ! 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
+       N = M 
+       return 
+     end function bugf
+   end program bug8
\ No newline at end of file
Index: gcc/testsuite/gfortran.dg/do_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/do_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/do_2.f90	(revision 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
+ 
Index: gcc/testsuite/gfortran.dg/data_char_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/data_char_1.f90	(revision 114326)
--- gcc/testsuite/gfortran.dg/data_char_1.f90	(working copy)
***************
*** 1,12 ****
  ! { dg-do run }
  ! Test character variables in data statements
! ! Also substrings of cahracter 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'/
    
    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
--- 1,13 ----
  ! { dg-do run }
  ! Test character variables in data statements
! ! 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'/       ! { 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