[multiple changes]

2007-05-16  Brooks Moses  <brooks.moses@codesourcery.com>

	PR fortran/18769
	PR fortran/30881
	PR fortran/31194
	PR fortran/31216
	PR fortran/31427
	* target-memory.c: New file.
	* target-memory.h: New file.
	* simplify.c: Add #include "target-memory.h".
	(gfc_simplify_transfer): Implement constant-
	folding for TRANSFER intrinsic.
	* Make-lang.in: Add dependencies on new target-memory.* files.

2007-05-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/18769
	PR fortran/30881
	PR fortran/31194
	PR fortran/31216
	PR fortran/31427
	* transfer_simplify_1.f90: New test.
	* transfer_simplify_2.f90: New test.

From-SVN: r124759

gcc/fortran/ChangeLog

+2007-05-16  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	PR fortran/18769
+	PR fortran/30881
+	PR fortran/31194
+	PR fortran/31216
+	PR fortran/31427
+	* target-memory.c: New file.
+	* target-memory.h: New file.
+	* simplify.c: Add #include "target-memory.h".
+	(gfc_simplify_transfer): Implement constant-
+	folding for TRANSFER intrinsic.
+	* Make-lang.in: Add dependencies on new target-memory.* files.
+
 2007-05-15  Paul Brook  <paul@codesourcery.com>
 
 	* trans-types.c (gfc_type_for_size): Handle signed TImode.

gcc/fortran/Make-lang.in

@@ -66,7 +66,7 @@ F95_PARSER_OBJS = fortran/arith.o fortran/array.o fortran/bbt.o \
     fortran/match.o fortran/matchexp.o fortran/misc.o fortran/module.o \
     fortran/openmp.o fortran/options.o fortran/parse.o fortran/primary.o \
     fortran/resolve.o fortran/scanner.o fortran/simplify.o fortran/st.o \
-    fortran/symbol.o
+    fortran/symbol.o fortran/target-memory.o
 
 F95_OBJS = $(F95_PARSER_OBJS) \
     fortran/convert.o fortran/dependency.o fortran/f95-lang.o \
@@ -297,7 +297,7 @@ fortran.stagefeedback: stageprofile-start
 # TODO: Add dependencies on the backend/tree header files
 
 $(F95_PARSER_OBJS): fortran/gfortran.h fortran/intrinsic.h fortran/match.h \
-		fortran/parse.h \
+		fortran/parse.h fortran/arith.h fortran/target-memory.h \
 		$(CONFIG_H) $(SYSTEM_H) $(TM_H) $(TM_P_H) coretypes.h \
 		$(RTL_H) $(TREE_H) $(TREE_DUMP_H) $(GGC_H) $(EXPR_H) \
 		$(FLAGS_H) output.h $(DIAGNOSTIC_H) errors.h $(FUNCTION_H) 

gcc/fortran/simplify.c

@@ -26,6 +26,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
 #include "gfortran.h"
 #include "arith.h"
 #include "intrinsic.h"
+#include "target-memory.h"
 
 gfc_expr gfc_bad_expr;
 
@@ -3865,12 +3866,81 @@ gfc_simplify_tiny (gfc_expr *e)
 gfc_expr *
 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
 {
-  /* Reference mold and size to suppress warning.  */
-  if (gfc_init_expr && (mold || size))
-    gfc_error ("TRANSFER intrinsic not implemented for initialization at %L",
-	       &source->where);
+  gfc_expr *result;
+  gfc_expr *mold_element;
+  size_t source_size;
+  size_t result_size;
+  size_t result_elt_size;
+  size_t buffer_size;
+  mpz_t tmp;
+  unsigned char *buffer;
+
+  if (!gfc_is_constant_expr (source)
+	|| !gfc_is_constant_expr (size))
+    return NULL;
 
-  return NULL;
+  /* Calculate the size of the source.  */
+  if (source->expr_type == EXPR_ARRAY
+      && gfc_array_size (source, &tmp) == FAILURE)
+    gfc_internal_error ("Failure getting length of a constant array.");
+
+  source_size = gfc_target_expr_size (source);
+
+  /* Create an empty new expression with the appropriate characteristics.  */
+  result = gfc_constant_result (mold->ts.type, mold->ts.kind,
+				&source->where);
+  result->ts = mold->ts;
+
+  mold_element = mold->expr_type == EXPR_ARRAY
+		 ? mold->value.constructor->expr
+		 : mold;
+
+  /* Set result character length, if needed.  Note that this needs to be
+     set even for array expressions, in order to pass this information into 
+     gfc_target_interpret_expr.  */
+  if (result->ts.type == BT_CHARACTER)
+    result->value.character.length = mold_element->value.character.length;
+  
+  /* Set the number of elements in the result, and determine its size.  */
+  result_elt_size = gfc_target_expr_size (mold_element);
+  if (mold->expr_type == EXPR_ARRAY || size)
+    {
+      int result_length;
+
+      result->expr_type = EXPR_ARRAY;
+      result->rank = 1;
+
+      if (size)
+	result_length = (size_t)mpz_get_ui (size->value.integer);
+      else
+	{
+	  result_length = source_size / result_elt_size;
+	  if (result_length * result_elt_size < source_size)
+	    result_length += 1;
+	}
+
+      result->shape = gfc_get_shape (1);
+      mpz_init_set_ui (result->shape[0], result_length);
+
+      result_size = result_length * result_elt_size;
+    }
+  else
+    {
+      result->rank = 0;
+      result_size = result_elt_size;
+    }
+
+  /* Allocate the buffer to store the binary version of the source.  */
+  buffer_size = MAX (source_size, result_size);
+  buffer = (unsigned char*)alloca (buffer_size);
+
+  /* Now write source to the buffer.  */
+  gfc_target_encode_expr (source, buffer, buffer_size);
+
+  /* And read the buffer back into the new expression.  */
+  gfc_target_interpret_expr (buffer, buffer_size, result);
+
+  return result;
 }
 
 

gcc/fortran/target-memory.h

+/* Simulate storage of variables into target memory, header.
+   Copyright (C) 2007
+   Free Software Foundation, Inc.
+   Contributed by Paul Thomas and Brooks Moses
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING.  If not, write to the Free
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.  */
+
+#ifndef GFC_TARGET_MEMORY_H
+#define GFC_TARGET_MEMORY_H
+
+#include "gfortran.h"
+
+/* Return the size of an expression in its target representation.  */
+size_t gfc_target_expr_size (gfc_expr *);
+
+/* Write a constant expression in binary form to a target buffer.  */
+int gfc_target_encode_expr (gfc_expr *, unsigned char *, size_t);
+
+/* Read a target buffer into a constant expression.  */
+int gfc_target_interpret_expr (unsigned char *, size_t, gfc_expr *);
+
+#endif /* GFC_TARGET_MEMORY_H  */

gcc/testsuite/ChangeLog

+2007-05-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/18769
+	PR fortran/30881
+	PR fortran/31194
+	PR fortran/31216
+	PR fortran/31427
+	* transfer_simplify_1.f90: New test.
+	* transfer_simplify_2.f90: New test.
+
 2007-05-15  Dominique d'Humieres  <dominiq@lps.ens.fr>
 
 	* gfortran.dg/unf_io_convert_3.f90: Fix dg directive.

gcc/testsuite/gfortran.dg/transfer_simplify_1.f90

+! { dg-do run }
+! { dg-options "-O2" }
+! Tests that the PRs caused by the lack of gfc_simplify_transfer are
+! now fixed. These were brought together in the meta-bug PR31237
+! (TRANSFER intrinsic).
+! Remaining PRs on 20070409 :-18769 30881 31194 31216 31424 31427
+!
+program simplify_transfer
+  CHARACTER(LEN=100) :: buffer="1.0 3.0"
+  call pr18769 ()
+  call pr30881 ()
+  call pr31194 ()
+  call pr31216 ()
+  call pr31427 ()
+contains
+  subroutine pr18769 ()
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+    implicit none
+    type t
+       integer :: i
+    end type t
+    type (t), parameter :: u = t (42)
+    integer,  parameter :: idx_list(1) = (/ 1 /)
+    integer             :: j(1) = transfer (u,  idx_list)
+    if (j(1) .ne. 42) call abort ()
+  end subroutine pr18769
+
+  subroutine pr30881 ()
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+    INTEGER, PARAMETER :: K=1
+    INTEGER ::  I
+    I=TRANSFER(.TRUE.,K)
+    SELECT CASE(I)
+      CASE(TRANSFER(.TRUE.,K))
+      CASE(TRANSFER(.FALSE.,K))
+        CALL ABORT()
+      CASE DEFAULT
+        CALL ABORT()
+    END SELECT
+    I=TRANSFER(.FALSE.,K)
+    SELECT CASE(I)
+      CASE(TRANSFER(.TRUE.,K))
+        CALL ABORT()
+      CASE(TRANSFER(.FALSE.,K))
+      CASE DEFAULT
+      CALL ABORT()
+    END SELECT
+  END subroutine pr30881
+
+  subroutine pr31194 ()
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+    real(kind(0d0)) :: NaN = transfer(ishft(int(z'FFF80000',8),32),0d0)
+    write (buffer,'(e12.5)') NaN
+    if (buffer(10:12) .ne. "NaN") call abort ()
+  end subroutine pr31194
+
+  subroutine pr31216 ()
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+    INTEGER :: I
+    REAL :: C,D
+    buffer = "  1.0  3.0"
+    READ(buffer,*) C,D
+    I=TRANSFER(C/D,I)
+    SELECT CASE(I)
+      CASE (TRANSFER(1.0/3.0,1))
+      CASE DEFAULT
+        CALL ABORT()
+    END SELECT
+  END subroutine pr31216
+
+  subroutine pr31427 ()
+!
+! Contributed by Michael Richmond <michael.a.richmond@nasa.gov>
+!
+    INTEGER(KIND=1) :: i(1)
+    i = (/ TRANSFER("a", 0_1) /)
+    if (i(1) .ne. ichar ("a")) call abort ()
+  END subroutine pr31427
+end program simplify_transfer

gcc/testsuite/gfortran.dg/transfer_simplify_2.f90

+! { dg-do run }
+! { dg-options "-O2" }
+! Tests the fix for the meta-bug PR31237 (TRANSFER intrinsic)
+! Exercises gfc_simplify_transfer a random walk through types and shapes
+! and compares its results with the middle-end version that operates on
+! variables.
+!
+  implicit none
+  call integer4_to_real4
+  call real4_to_integer8
+  call integer4_to_integer8
+  call logical4_to_real8
+  call real8_to_integer4
+  call integer8_to_real4
+  call integer8_to_complex4
+  call character16_to_complex8
+  call character16_to_real8
+  call real8_to_character2
+  call dt_to_integer1
+  call character16_to_dt
+contains
+  subroutine integer4_to_real4
+    integer(4), parameter ::  i1 = 11111_4
+    integer(4)            ::  i2 = i1
+    real(4), parameter    ::  r1 = transfer (i1, 1.0_4)
+    real(4)               ::  r2
+
+    r2 = transfer (i2, r2);
+    if (r1 .ne. r2) call abort ()
+  end subroutine integer4_to_real4
+
+  subroutine real4_to_integer8
+    real(4), parameter    ::  r1(2) = (/3.14159_4, 0.0_4/)
+    real(4)               ::  r2(2) = r1
+    integer(8), parameter ::  i1 = transfer (r1, 1_8)
+    integer(8)            ::  i2
+
+    i2 = transfer (r2, 1_8);
+    if (i1 .ne. i2) call abort ()
+  end subroutine real4_to_integer8
+
+  subroutine integer4_to_integer8
+    integer(4), parameter ::  i1(2) = (/11111_4, 22222_4/)
+    integer(4)            ::  i2(2) = i1
+    integer(8), parameter ::  i3 = transfer (i1, 1_8)
+    integer(8)            ::  i4
+
+    i4 = transfer (i2, 1_8);
+    if (i3 .ne. i4) call abort ()
+  end subroutine integer4_to_integer8
+
+  subroutine logical4_to_real8
+    logical(4), parameter ::  l1(2) = (/.false., .true./)
+    logical(4)            ::  l2(2) = l1
+    real(8), parameter    ::  r1 = transfer (l1, 1_8)
+    real(8)               ::  r2
+
+    r2 = transfer (l2, 1_8);
+    if (r1 .ne. r2) call abort ()
+  end subroutine logical4_to_real8
+
+  subroutine real8_to_integer4
+    real(8), parameter    ::  r1 = 3.14159_8
+    real(8)               ::  r2 = r1
+    integer(4), parameter ::  i1(2) = transfer (r1, 1_4, 2)
+    integer(4)            ::  i2(2)
+
+    i2 = transfer (r2, i2, 2);
+    if (any (i1 .ne. i2)) call abort ()
+  end subroutine real8_to_integer4
+
+  subroutine integer8_to_real4
+    integer               ::  k
+    integer(8), parameter ::  i1(2) = transfer ((/asin (1.0_8), log (1.0_8)/), i1)
+    integer(8)            ::  i2(2) = i1
+    real(4), parameter    ::  r1(4) = transfer (i1, (/(1.0_4,k=1,4)/))
+    real(4)               ::  r2(4)
+
+    r2 = transfer (i2, r2);
+    if (any (r1 .ne. r2)) call abort ()
+  end subroutine integer8_to_real4
+
+  subroutine integer8_to_complex4
+    integer               ::  k
+    integer(8), parameter ::  i1(2) = transfer ((/asin (1.0_8), log (1.0_8)/), i1)
+    integer(8)            ::  i2(2) = i1
+    complex(4), parameter ::  z1(2) = transfer (i1, (/((1.0_4,2.0_4),k=1,2)/))
+    complex(4)            ::  z2(2)
+
+    z2 = transfer (i2, z2);
+    if (any (z1 .ne. z2)) call abort ()
+  end subroutine integer8_to_complex4
+
+  subroutine character16_to_complex8
+    character(16), parameter ::  c1(2) = (/"abcdefghijklmnop","qrstuvwxyz1234567890"/)
+    character(16)            ::  c2(2) = c1
+    complex(8), parameter    ::  z1(2) = transfer (c1, (1.0_8,1.0_8), 2)
+    complex(8)               ::  z2(2)
+
+    z2 = transfer (c2, z2, 2);
+    if (any (z1 .ne. z2)) call abort ()
+  end subroutine character16_to_complex8
+
+  subroutine character16_to_real8
+    character(16), parameter ::  c1 = "abcdefghijklmnop"
+    character(16)            ::  c2 = c1
+    real(8), parameter    ::  r1(2) = transfer (c1, 1.0_8, 2)
+    real(8)               ::  r2(2)
+
+    r2 = transfer (c2, r2, 2);
+    if (any (r1 .ne. r2)) call abort ()
+  end subroutine character16_to_real8
+
+  subroutine real8_to_character2
+    real(8), parameter    ::  r1 = 3.14159_8
+    real(8)               ::  r2 = r1
+    character(2), parameter ::  c1(4) = transfer (r1, "ab", 4)
+    character(2)            ::  c2(4)
+
+    c2 = transfer (r2, "ab", 4);
+    if (any (c1 .ne. c2)) call abort ()
+  end subroutine real8_to_character2
+
+  subroutine dt_to_integer1
+    integer, parameter    :: i1(4) = (/1_4,2_4,3_4,4_4/)
+    real, parameter       :: r1(4) = (/1.0_4,2.0_4,3.0_4,4.0_4/)
+    type :: mytype
+      integer(4) :: i(4)
+      real(4) :: x(4)
+    end type mytype
+    type (mytype), parameter :: dt1 = mytype (i1, r1)
+    type (mytype)            :: dt2 = dt1
+    integer(1), parameter :: i2(32) = transfer (dt1, 1_1, 32)
+    integer(1)            :: i3(32)
+
+    i3 = transfer (dt2, 1_1, 32);
+    if (any (i2 .ne. i3)) call abort ()
+  end subroutine dt_to_integer1
+
+  subroutine character16_to_dt
+    character(16), parameter ::  c1 = "abcdefghijklmnop"
+    character(16)            ::  c2 = c1
+    type :: mytype
+      real(4) :: x(2)
+    end type mytype
+
+    type (mytype), parameter :: dt1(2) = transfer (c1, mytype ((/1.0,2.0,3.0,4.0/)), 2)
+    type (mytype)            :: dt2(2)
+
+    dt2 = transfer (c2, dt2);
+    if (any (dt1(1)%x .ne. dt2(1)%x)) call abort ()
+    if (any (dt1(2)%x .ne. dt2(2)%x)) call abort ()
+  end subroutine character16_to_dt
+
+end