[Patch, fortran] PR26976 - Detect non-compliance of elemental intrinsics.

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

:ADDPATCH fortran:

This patch allows gfortran to detect the compliance or otherwise of the 
results of elemental intrinsics and of the TRANSFER intrinsic.  The 
patch is straightforward enough that the ChangeLog entry and the .diff 
file are sufficient description.

Initialization_1.f90 had a non-compliant assignment and so has been 
modified.  I have taken this opportunity to introduce the new, compliant 
testcases for the TRANSFER intrinsic; these also do the right thing with 
bigendian systems.  It should be noted that the original of the 
bigendian test used a PARAMETER and an intialization expression - this 
breaks as soon as optimization is switched on.  I will submit a bug 
report tomorrow;  I am not sure if this is a frontend or a backend 
problem, however.

Regtested on FC3/Athlon - OK for trunk and 4.1?

Paul

2006-04-01  Paul Thomas  <pault@gcc.gnu.org>

   PR fortran/26976
   * array.c (gfc_array_dimen_size): If available, return shape[dimen].
   * resolve.c (resolve_function): If available, use the argument shape 
for the
   function expression.
   * iresolve.c (gfc_resolve_transfer): Set shape[0] = size.

2006-04-01  Paul Thomas  <pault@gcc.gnu.org>

   PR fortran/26976
   * gfortran.dg/compliant_elemental_intrinsics_1.f90: New test.
   * gfortran.dg/initialization_1.f90: Make assignment compliant.
   * gfortran.dg/transfer_array_intrinsic_1.f90: Simplify.
   * gfortran.dg/transfer_array_intrinsic_2.f90: Make assignments 
compliant and detect
   bigendian-ness.

Index: gcc/testsuite/gfortran.dg/compliant_elemental_intrinsics_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/compliant_elemental_intrinsics_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/compliant_elemental_intrinsics_1.f90	(revision 0)
***************
*** 0 ****
--- 1,26 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR26976, in which non-compliant elemental
+ ! intrinsic function results were not detected.  At the same
+ ! time, the means to tests the compliance of TRANSFER with the
+ ! optional SIZE parameter was added.
+ !
+ ! Contributed by Dominique Dhumieres  <dominiq@lps.ens.fr>
+ !
+ real(4) :: pi, a(2), b(3)
+ character(26) :: ch
+ 
+ pi = acos(-1.0)
+ b = pi
+ 
+ a = cos(b) ! { dg-error "different shape for Array assignment" }
+ 
+ a = -pi
+ b = cos(a) ! { dg-error "different shape for Array assignment" }
+ 
+ ch = "abcdefghijklmnopqrstuvwxyz"
+ a = transfer (ch, pi, 3) ! { dg-error "different shape for Array assignment" }
+ 
+ ! This already generated an error
+ b = reshape ((/1.0/),(/1/)) ! { dg-error "different shape for Array assignment" }
+ 
+ end
Index: gcc/testsuite/gfortran.dg/initialization_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/initialization_1.f90	(revision 112441)
--- gcc/testsuite/gfortran.dg/initialization_1.f90	(working copy)
*************** contains
*** 21,26 ****
--- 21,27 ----
      real(8) :: x (1:2, *)
      real(8) :: y (0:,:)
      integer :: i
+     real :: z(2, 2)
  
  ! However, this gives a warning because it is an initialization expression.
      integer :: l1 = len (ch1)     ! { dg-warning "assumed character length variable" }
Index: gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90	(revision 112441)
--- gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90	(working copy)
***************
*** 1,22 ****
! ! { dg-do run { target i?86-*-* x86_64-*-* } }
  ! Tests the patch to implement the array version of the TRANSFER
  ! intrinsic (PR17298).
- ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
  
!    character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/)
! 
! ! tests numeric transfers(including PR testcase).
  
     call test1 ()
  
- ! tests numeric/character transfers.
- 
-    call test2 ()
- 
- ! Test dummies, automatic objects and assumed character length.
- 
-    call test3 (ch, ch, ch, 8)
- 
  contains
  
     subroutine test1 ()
--- 1,11 ----
! ! { dg-do run }
  ! Tests the patch to implement the array version of the TRANSFER
  ! intrinsic (PR17298).
  
! ! test the PR is fixed.
  
     call test1 ()
  
  contains
  
     subroutine test1 ()
*************** contains
*** 29,118 ****
       cmp = transfer (z, cmp) * 2.0
       if (any (cmp .ne. (/2.0, 4.0/))) call abort ()
  
- ! Check that size smaller than the source word length is OK.
- 
-      z = (-1.0, -2.0)
-      cmp = transfer (z, cmp, 1) * 8.0
-      if (any (cmp .ne. (/-8.0, 4.0/))) call abort ()
- 
- ! Check multi-dimensional sources and that transfer works as an actual
- ! argument of reshape.
- 
-      a = reshape ((/(rand (), i = 1, 16)/), (/4,4/))
-      jt = transfer (a, it)
-      it = reshape (jt, (/4, 2, 4/))
-      if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort ()
- 
     end subroutine test1
  
-    subroutine test2 ()
-      integer(4) :: y(4), z(2)
-      character(4) :: ch(4)
-      y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) &
-               + ishft (i + 3, 24), i = 65, 80 , 4)/)
- 
- ! Check source array sections in both directions.
- 
-      ch = "wxyz"
-      ch = transfer (y(2:4:2), ch)
-      if (any (ch .ne. (/"EFGH","MNOP","wxyz","wxyz"/))) call abort ()
-      ch = "wxyz"
-      ch = transfer (y(4:2:-2), ch)
-      if (any (ch .ne. (/"MNOP","EFGH","wxyz","wxyz"/))) call abort ()
- 
- ! Check that a complete array transfers with size absent.
- 
-      ch = transfer (y, ch)
-      if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort ()
- 
- ! Check that a character array section is OK
- 
-      z = transfer (ch(2:3), y)
-      if (any (z .ne. y(2:3))) call abort ()
- 
- ! Check dest array sections in both directions.
- 
-      ch = "wxyz"
-      ch(3:4) = transfer (y, ch, 2)
-      if (any (ch .ne. (/"wxyz","wxyz","ABCD","EFGH"/))) call abort ()
-      ch = "wxyz"
-      ch(3:2:-1) = transfer (y, ch, 3)
-      if (any (ch .ne. (/"wxyz","EFGH","ABCD","wxyz"/))) call abort ()
- 
- ! Check that too large a value of size is cut off.
- 
-      ch = "wxyz"
-      ch(1:2) = transfer (y, ch, 3)
-      if (any (ch .ne. (/"ABCD","EFGH","wxyz","wxyz"/))) call abort ()
- 
- ! Make sure that character to numeric is OK.
- 
-      z = transfer (ch, y)
-      if (any (y(1:2) .ne. z)) call abort ()
- 
-    end subroutine test2
- 
-    subroutine test3 (ch1, ch2, ch3, clen)
-      integer clen
-      character(8) :: ch1(:)
-      character(*) :: ch2(2)
-      character(clen) :: ch3(2)
-      character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/)
-      integer(8) :: ic(2)
-      ic = transfer (cntrl, ic)
- 
- ! Check assumed shape.
- 
-      if (any (ic .ne. transfer (ch1, ic))) call abort ()
- 
- ! Check assumed character length.
- 
-      if (any (ic .ne. transfer (ch2, ic))) call abort ()
- 
- ! Check automatic character length.
- 
-      if (any (ic .ne. transfer (ch3, ic))) call abort ()
- 
-   end subroutine test3
- 
  end
--- 18,23 ----
Index: gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90	(revision 112441)
--- gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90	(working copy)
***************
*** 1,23 ****
! ! { dg-do run { target i?86-*-* x86_64-*-* } }
! ! { dg-options "-fpack-derived" }
!    call test3()
  contains
!    subroutine test3 ()
!      type mytype
!        sequence
!        real(8) :: x = 3.14159
!        character(4) :: ch = "wxyz"
!        integer(2) :: i = 77
!      end type mytype
!      type(mytype) :: z(2)
!      character(1) :: c(32)
!      character(4) :: chr
!      real(8) :: a
!      integer(2) :: l
!      equivalence (a, c(15)), (chr, c(23)), (l, c(27))
!      c = transfer(z, c)
!      if (a .ne. z(1)%x) call abort ()
!      if (chr .ne. z(1)%ch) call abort ()
!      if (l .ne. z(1)%i) call abort ()
!    end subroutine test3
  end
--- 1,118 ----
! ! { dg-do run }
! ! Tests the patch to implement the array version of the TRANSFER
! ! intrinsic (PR17298).
! ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
! 
! ! Bigendian test posted by Perseus in comp.lang.fortran on 4 July 2005.
! ! Original had parameter but this fails, at present, with -Ox, x>0
! 
!    LOGICAL :: bigend
! 
!    character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/)
! 
!    bigend = IACHAR(TRANSFER(1,"a")) == 0
! 
! ! tests numeric transfers other than original testscase.
! 
!    call test1 ()
! 
! ! tests numeric/character transfers.
! 
!    call test2 ()
! 
! ! Test dummies, automatic objects and assumed character length.
! 
!    call test3 (ch, ch, ch, 8)
! 
  contains
! 
!    subroutine test1 ()
!      real(4) :: a(4, 4)
!      integer(2) :: it(4, 2, 4), jt(32)
! 
! ! Check multi-dimensional sources and that transfer works as an actual
! ! argument of reshape.
! 
!      a = reshape ((/(rand (), i = 1, 16)/), (/4,4/))
!      jt = transfer (a, it)
!      it = reshape (jt, (/4, 2, 4/))
!      if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort ()
! 
!    end subroutine test1
! 
!    subroutine test2 ()
!      integer(4) :: y(4), z(2)
!      character(4) :: ch(4)
! 
! ! Allow for endian-ness
!      if (bigend) then
!        y = (/(i + 3 + ishft (i + 2, 8) + ishft (i + 1, 16) &
!                 + ishft (i, 24), i = 65, 80 , 4)/)
!      else 
!        y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) &
!                 + ishft (i + 3, 24), i = 65, 80 , 4)/)
!      end if
! 
! ! Check source array sections in both directions.
! 
!      ch = "wxyz"
!      ch(1:2) = transfer (y(2:4:2), ch)
!      if (any (ch(1:2) .ne. (/"EFGH","MNOP"/))) call abort ()
!      ch = "wxyz"
!      ch(1:2) = transfer (y(4:2:-2), ch)
!      if (any (ch(1:2) .ne. (/"MNOP","EFGH"/))) call abort ()
! 
! ! Check that a complete array transfers with size absent.
! 
!      ch = transfer (y, ch)
!      if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort ()
! 
! ! Check that a character array section is OK
! 
!      z = transfer (ch(2:3), y)
!      if (any (z .ne. y(2:3))) call abort ()
! 
! ! Check dest array sections in both directions.
! 
!      ch = "wxyz"
!      ch(3:4) = transfer (y, ch, 2)
!      if (any (ch(3:4) .ne. (/"ABCD","EFGH"/))) call abort ()
!      ch = "wxyz"
!      ch(3:2:-1) = transfer (y, ch, 2)
!      if (any (ch(2:3) .ne. (/"EFGH","ABCD"/))) call abort ()
! 
! ! Make sure that character to numeric is OK.
! 
!      ch = "wxyz"
!      ch(1:2) = transfer (y, ch, 2)
!      if (any (ch(1:2) .ne. (/"ABCD","EFGH"/))) call abort ()
! 
!      z = transfer (ch, y)
!      if (any (y(1:2) .ne. z)) call abort ()
! 
!    end subroutine test2
! 
!    subroutine test3 (ch1, ch2, ch3, clen)
!      integer clen
!      character(8) :: ch1(:)
!      character(*) :: ch2(2)
!      character(clen) :: ch3(2)
!      character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/)
!      integer(8) :: ic(2)
!      ic = transfer (cntrl, ic)
! 
! ! Check assumed shape.
! 
!      if (any (ic .ne. transfer (ch1, ic))) call abort ()
! 
! ! Check assumed character length.
! 
!      if (any (ic .ne. transfer (ch2, ic))) call abort ()
! 
! ! Check automatic character length.
! 
!      if (any (ic .ne. transfer (ch3, ic))) call abort ()
! 
!   end subroutine test3
! 
  end
Index: gcc/fortran/array.c
===================================================================
*** gcc/fortran/array.c	(revision 112441)
--- gcc/fortran/array.c	(working copy)
*************** gfc_array_dimen_size (gfc_expr * array, 
*** 1872,1877 ****
--- 1872,1883 ----
  	    }
  	}
  
+       if (array->shape && array->shape[dimen])
+ 	{
+ 	  mpz_init_set (*result, array->shape[dimen]);
+ 	  return SUCCESS;
+ 	}
+ 
        if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
  	return FAILURE;
  
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 112441)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_function (gfc_expr * expr)
*** 1205,1210 ****
--- 1205,1211 ----
    const char *name;
    try t;
    int temp;
+   int i;
  
    sym = NULL;
    if (expr->symtree)
*************** resolve_function (gfc_expr * expr)
*** 1304,1309 ****
--- 1305,1316 ----
  	  if (arg->expr != NULL && arg->expr->rank > 0)
  	    {
  	      expr->rank = arg->expr->rank;
+ 	      if (!expr->shape && arg->expr->shape)
+ 		{
+ 		  expr->shape = gfc_get_shape (expr->rank);
+ 		  for (i = 0; i < expr->rank; i++)
+ 		    mpz_init_set (expr->shape[i], arg->expr->shape[i]);
+ 	        }
  	      break;
  	    }
  	}
Index: gcc/fortran/iresolve.c
===================================================================
*** gcc/fortran/iresolve.c	(revision 112441)
--- gcc/fortran/iresolve.c	(working copy)
*************** gfc_resolve_transfer (gfc_expr * f, gfc_
*** 1955,1960 ****
--- 1955,1965 ----
      {
        f->rank = 1;
        f->value.function.name = transfer1;
+       if (size && gfc_is_constant_expr (size))
+ 	{
+ 	  f->shape = gfc_get_shape (1);
+ 	  mpz_init_set (f->shape[0], size->value.integer);
+ 	}
      }
  }