OSDN Git Service

2007-05-16 Brooks Moses <brooks.moses@codesourcery.com>
authorpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 16 May 2007 05:40:51 +0000 (05:40 +0000)
committerpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 16 May 2007 05:40:51 +0000 (05:40 +0000)
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.

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

gcc/fortran/ChangeLog
gcc/fortran/Make-lang.in
gcc/fortran/simplify.c
gcc/fortran/target-memory.c [new file with mode: 0644]
gcc/fortran/target-memory.h [new file with mode: 0644]
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/transfer_simplify_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/transfer_simplify_2.f90 [new file with mode: 0644]

index 83a808d..d89c888 100644 (file)
@@ -1,3 +1,17 @@
+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.
index 4c70771..f9053dc 100644 (file)
@@ -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) 
index ed62ee3..87fe6f1 100644 (file)
@@ -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;
 }
 
 
diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c
new file mode 100644 (file)
index 0000000..ba2363a
--- /dev/null
@@ -0,0 +1,451 @@
+/* Simulate storage of variables into target memory.
+   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.  */
+
+#include "config.h"
+#include "system.h"
+#include "flags.h"
+#include "machmode.h"
+#include "tree.h"
+#include "gfortran.h"
+#include "arith.h"
+#include "trans.h"
+#include "trans-const.h"
+#include "trans-types.h"
+#include "target-memory.h"
+
+/* --------------------------------------------------------------- */ 
+/* Calculate the size of an expression.  */
+
+static size_t
+size_array (gfc_expr *e)
+{
+  mpz_t array_size;
+  size_t elt_size = gfc_target_expr_size (e->value.constructor->expr);
+
+  gfc_array_size (e, &array_size);
+  return (size_t)mpz_get_ui (array_size) * elt_size;
+}
+
+static size_t
+size_integer (int kind)
+{
+  return GET_MODE_SIZE (TYPE_MODE (gfc_get_int_type (kind)));;
+}
+
+
+static size_t
+size_float (int kind)
+{
+  return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind)));;
+}
+
+
+static size_t
+size_complex (int kind)
+{
+  return 2 * size_float (kind);
+}
+
+
+static size_t
+size_logical (int kind)
+{
+  return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind)));;
+}
+
+
+static size_t
+size_character (int length)
+{
+  return length;
+}
+
+
+size_t
+gfc_target_expr_size (gfc_expr *e)
+{
+  tree type;
+
+  gcc_assert (e != NULL);
+
+  if (e->expr_type == EXPR_ARRAY)
+    return size_array (e);
+
+  switch (e->ts.type)
+    {
+    case BT_INTEGER:
+      return size_integer (e->ts.kind);
+    case BT_REAL:
+      return size_float (e->ts.kind);
+    case BT_COMPLEX:
+      return size_complex (e->ts.kind);
+    case BT_LOGICAL:
+      return size_logical (e->ts.kind);
+    case BT_CHARACTER:
+      return size_character (e->value.character.length);
+    case BT_DERIVED:
+      type = gfc_typenode_for_spec (&e->ts);
+      return int_size_in_bytes (type);
+    default:
+      gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
+      return 0;
+    }
+}
+
+
+/* The encode_* functions export a value into a buffer, and 
+   return the number of bytes of the buffer that have been
+   used.  */
+
+static int
+encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
+{
+  mpz_t array_size;
+  int i;
+  int ptr = 0;
+
+  gfc_array_size (expr, &array_size);
+  for (i = 0; i < (int)mpz_get_ui (array_size); i++)
+    {
+      ptr += gfc_target_encode_expr (gfc_get_array_element (expr, i),
+                                    &buffer[ptr], buffer_size - ptr);
+    }
+
+  mpz_clear (array_size);
+  return ptr;
+}
+
+
+static int
+encode_integer (int kind, mpz_t integer, unsigned char *buffer,
+               size_t buffer_size)
+{
+  return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
+                            buffer, buffer_size);
+}
+
+
+static int
+encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
+{
+  return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind), buffer,
+                            buffer_size);
+}
+
+
+static int
+encode_complex (int kind, mpfr_t real, mpfr_t imaginary, unsigned char *buffer,
+               size_t buffer_size)
+{
+  int size;
+  size = encode_float (kind, real, &buffer[0], buffer_size);
+  size += encode_float (kind, imaginary, &buffer[size], buffer_size - size);
+  return size;
+}
+
+
+static int
+encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
+{
+  return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
+                                           logical),
+                            buffer, buffer_size);
+}
+
+
+static int
+encode_character (int length, char *string, unsigned char *buffer,
+                 size_t buffer_size)
+{
+  gcc_assert (buffer_size >= size_character (length));
+  memcpy (buffer, string, length);
+  return length;
+}
+
+
+static int
+encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
+{
+  gfc_constructor *ctr;
+  gfc_component *cmp;
+  int ptr;
+  tree type;
+
+  type = gfc_typenode_for_spec (&source->ts);
+
+  ctr = source->value.constructor;
+  cmp = source->ts.derived->components;
+  for (;ctr; ctr = ctr->next, cmp = cmp->next)
+    {
+      gcc_assert (ctr->expr && cmp);
+      ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
+      gfc_target_encode_expr (ctr->expr, &buffer[ptr],
+                             buffer_size - ptr);
+    }
+
+  return int_size_in_bytes (type);
+}
+
+
+/* Write a constant expression in binary form to a buffer.  */
+int
+gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
+                       size_t buffer_size)
+{
+  if (source == NULL)
+    return 0;
+
+  if (source->expr_type == EXPR_ARRAY)
+    return encode_array (source, buffer, buffer_size);
+
+  gcc_assert (source->expr_type == EXPR_CONSTANT
+             || source->expr_type == EXPR_STRUCTURE);
+
+  switch (source->ts.type)
+    {
+    case BT_INTEGER:
+      return encode_integer (source->ts.kind, source->value.integer, buffer,
+                            buffer_size);
+    case BT_REAL:
+      return encode_float (source->ts.kind, source->value.real, buffer,
+                          buffer_size);
+    case BT_COMPLEX:
+      return encode_complex (source->ts.kind, source->value.complex.r,
+                            source->value.complex.i, buffer, buffer_size);
+    case BT_LOGICAL:
+      return encode_logical (source->ts.kind, source->value.logical, buffer,
+                            buffer_size);
+    case BT_CHARACTER:
+      return encode_character (source->value.character.length, 
+                              source->value.character.string, buffer,
+                              buffer_size);
+    case BT_DERIVED:
+      return encode_derived (source, buffer, buffer_size);
+    default:
+      gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
+      return 0;
+    }
+}
+
+
+static int
+interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
+{
+  int array_size = 1;
+  int i;
+  int ptr = 0;
+  gfc_constructor *head = NULL, *tail = NULL;
+
+  /* Calculate array size from its shape and rank.  */
+  gcc_assert (result->rank > 0 && result->shape);
+
+  for (i = 0; i < result->rank; i++)
+    array_size *= (int)mpz_get_ui (result->shape[i]);
+
+  /* Iterate over array elements, producing constructors.  */
+  for (i = 0; i < array_size; i++)
+    {
+      if (head == NULL)
+       head = tail = gfc_get_constructor ();
+      else
+       {
+         tail->next = gfc_get_constructor ();
+         tail = tail->next;
+       }
+
+      tail->where = result->where;
+      tail->expr = gfc_constant_result (result->ts.type,
+                                         result->ts.kind, &result->where);
+      tail->expr->ts = result->ts;
+
+      if (tail->expr->ts.type == BT_CHARACTER)
+       tail->expr->value.character.length = result->value.character.length;
+
+      ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
+                                       tail->expr);
+    }
+  result->value.constructor = head;
+
+  return ptr;
+}
+
+
+static int
+interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
+                  mpz_t integer)
+{
+  mpz_init (integer);
+  gfc_conv_tree_to_mpz (integer,
+                       native_interpret_expr (gfc_get_int_type (kind),
+                                              buffer, buffer_size));
+  return size_integer (kind);
+}
+
+
+static int
+interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
+                mpfr_t real)
+{
+  mpfr_init (real);
+  gfc_conv_tree_to_mpfr (real,
+                        native_interpret_expr (gfc_get_real_type (kind),
+                                               buffer, buffer_size));
+
+  return size_float (kind);
+}
+
+
+static int
+interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
+                  mpfr_t real, mpfr_t imaginary)
+{
+  int size;
+  size = interpret_float (kind, &buffer[0], buffer_size, real);
+  size += interpret_float (kind, &buffer[size], buffer_size - size, imaginary);
+  return size;
+}
+
+
+static int
+interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
+                  int *logical)
+{
+  tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
+                                 buffer_size);
+  *logical = double_int_zero_p (tree_to_double_int (t))
+            ? 0 : 1;
+  return size_logical (kind);
+}
+
+
+static int
+interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
+{
+  if (result->ts.cl && result->ts.cl->length)
+    result->value.character.length =
+      (int)mpz_get_ui (result->ts.cl->length->value.integer);
+
+  gcc_assert (buffer_size >= size_character (result->value.character.length));
+  result->value.character.string =
+    gfc_getmem (result->value.character.length + 1);
+  memcpy (result->value.character.string, buffer,
+         result->value.character.length);
+  result->value.character.string [result->value.character.length] = '\0';
+
+  return result->value.character.length;
+}
+
+
+static int
+interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
+{
+  gfc_component *cmp;
+  gfc_constructor *head = NULL, *tail = NULL;
+  int ptr;
+  tree type;
+
+  /* The attributes of the derived type need to be bolted to the floor.  */
+  result->expr_type = EXPR_STRUCTURE;
+
+  type = gfc_typenode_for_spec (&result->ts);
+  cmp = result->ts.derived->components;
+
+  /* Run through the derived type components.  */
+  for (;cmp; cmp = cmp->next)
+    {
+      if (head == NULL)
+       head = tail = gfc_get_constructor ();
+      else
+       {
+         tail->next = gfc_get_constructor ();
+         tail = tail->next;
+       }
+
+      /* The constructor points to the component.  */
+      tail->n.component = cmp;
+
+      tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind,
+                                       &result->where);
+      tail->expr->ts = cmp->ts;
+
+      /* Copy shape, if needed.  */
+      if (cmp->as && cmp->as->rank)
+       {
+         int n;
+
+         tail->expr->expr_type = EXPR_ARRAY;
+         tail->expr->rank = cmp->as->rank;
+
+         tail->expr->shape = gfc_get_shape (tail->expr->rank);
+         for (n = 0; n < tail->expr->rank; n++)
+            {
+              mpz_init_set_ui (tail->expr->shape[n], 1);
+              mpz_add (tail->expr->shape[n], tail->expr->shape[n],
+                       cmp->as->upper[n]->value.integer);
+              mpz_sub (tail->expr->shape[n], tail->expr->shape[n],
+                       cmp->as->lower[n]->value.integer);
+            }
+       }
+
+      ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
+      gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
+                                tail->expr);
+
+      result->value.constructor = head;
+    }
+    
+  return int_size_in_bytes (type);
+}
+
+
+/* Read a binary buffer to a constant expression.  */
+int
+gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
+                          gfc_expr *result)
+{
+  if (result->expr_type == EXPR_ARRAY)
+    return interpret_array (buffer, buffer_size, result);
+
+  switch (result->ts.type)
+    {
+    case BT_INTEGER:
+      return interpret_integer (result->ts.kind, buffer, buffer_size,
+                               result->value.integer);
+    case BT_REAL:
+      return interpret_float (result->ts.kind, buffer, buffer_size,
+                             result->value.real);
+    case BT_COMPLEX:
+      return interpret_complex (result->ts.kind, buffer, buffer_size,
+                               result->value.complex.r,
+                               result->value.complex.i);
+    case BT_LOGICAL:
+      return interpret_logical (result->ts.kind, buffer, buffer_size,
+                               &result->value.logical);
+    case BT_CHARACTER:
+      return interpret_character (buffer, buffer_size, result);
+    case BT_DERIVED:
+      return interpret_derived (buffer, buffer_size, result);
+    default:
+      gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
+    }
+  return 0;
+}
diff --git a/gcc/fortran/target-memory.h b/gcc/fortran/target-memory.h
new file mode 100644 (file)
index 0000000..85ae552
--- /dev/null
@@ -0,0 +1,37 @@
+/* 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  */
index 1bb53a6..ee74a8f 100644 (file)
@@ -1,3 +1,13 @@
+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.
diff --git a/gcc/testsuite/gfortran.dg/transfer_simplify_1.f90 b/gcc/testsuite/gfortran.dg/transfer_simplify_1.f90
new file mode 100644 (file)
index 0000000..c1b241f
--- /dev/null
@@ -0,0 +1,87 @@
+! { 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
diff --git a/gcc/testsuite/gfortran.dg/transfer_simplify_2.f90 b/gcc/testsuite/gfortran.dg/transfer_simplify_2.f90
new file mode 100644 (file)
index 0000000..8f0380a
--- /dev/null
@@ -0,0 +1,155 @@
+! { 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