This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[patch, fortran] Implement constant-folding for TRANSFER intrinsic.
- From: Brooks Moses <brooks dot moses at codesourcery dot com>
- To: fortran at gcc dot gnu dot org, gcc-patches at gcc dot gnu dot org
- Cc: "Paul Richard Thomas" <paul dot richard dot thomas at gmail dot com>, "François-Xavier Coudert" <fxcoudert at gmail dot com>
- Date: Fri, 11 May 2007 15:30:48 -0700
- Subject: [patch, fortran] Implement constant-folding for TRANSFER intrinsic.
This patch adds the long-awaited implementation for constant-folding for
the TRANSFER intrinsic. It's essentially the same as the provisional
one that I posted a few weeks ago, with the addition of two testcases
provided by Paul Thomas.
As noted earlier, this implementation is entirely independent of the
build system's memory representation; all of the transfers of values
from gfc_expr representations to memory representations are done using
the middle-end functions in fold-const.c, which are what it uses for
similar constant-folding. The in-memory size of expressions is
calculated using the same code as the fold-const.c functions use.
(As I shall have limited net access for the next week, Paul and FX have
generously offered to address any final tweaks that need to be made to
this.)
Regression tested on powerpc-apple-darwin8.9.0 (and slightly earlier
versions tested on i686-pc-linux-gnu). Ok for trunk?
- Brooks
---------------------------------------------------------------------
2007-05-11 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-11 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.
---------------------------------------------------------------------
Index: fortran/simplify.c
===================================================================
--- fortran/simplify.c (revision 124476)
+++ fortran/simplify.c (working copy)
@@ -26,6 +26,7 @@
#include "gfortran.h"
#include "arith.h"
#include "intrinsic.h"
+#include "target-memory.h"
gfc_expr gfc_bad_expr;
@@ -3870,12 +3871,82 @@
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;
- return NULL;
+ if (!gfc_is_constant_expr (source)
+ || !gfc_is_constant_expr (size))
+ 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 != NULL)
+ {
+ 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 = source_size > result_size ? source_size : result_size;
+ buffer = gfc_getmem (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);
+
+ gfc_free (buffer);
+ return result;
}
Index: fortran/Make-lang.in
===================================================================
--- fortran/Make-lang.in (revision 124476)
+++ fortran/Make-lang.in (working copy)
@@ -66,7 +66,7 @@
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 @@
# 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: fortran/target-memory.c
===================================================================
--- fortran/target-memory.c (revision 0)
+++ fortran/target-memory.c (revision 0)
@@ -0,0 +1,447 @@
+/* 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 kind * 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)
+{
+ gfc_constructor *ctr;
+ size_t expr_size = 0;
+
+ 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:
+ ctr = e->value.constructor;
+ for (;ctr; ctr = ctr->next)
+ {
+ gcc_assert (ctr->expr != NULL);
+ expr_size += gfc_target_expr_size (ctr->expr);
+ }
+ return expr_size;
+ 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;
+ int ptr = 0;
+
+ ctr = source->value.constructor;
+ for (;ctr; ctr = ctr->next)
+ {
+ gcc_assert (ctr->expr != NULL);
+ ptr += gfc_target_encode_expr (ctr->expr, &buffer[ptr],
+ buffer_size - ptr);
+ }
+ return ptr;
+}
+
+
+/* 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. */
+ if (result->rank == 0 || result->shape == NULL)
+ gfc_error ("failure to obtain array size at %L", &result->where);
+
+ 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 = 0;
+
+ /* The attributes of the derived type need to be bolted to the floor. */
+ result->expr_type = EXPR_STRUCTURE;
+
+ 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 += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
+ tail->expr);
+
+ result->value.constructor = head;
+ }
+ return ptr;
+}
+
+
+/* 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;
+}
Index: fortran/target-memory.h
===================================================================
--- fortran/target-memory.h (revision 0)
+++ fortran/target-memory.h (revision 0)
@@ -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: testsuite/gfortran.dg/transfer_simplify_1.f90
===================================================================
--- testsuite/gfortran.dg/transfer_simplify_1.f90 (revision 0)
+++ testsuite/gfortran.dg/transfer_simplify_1.f90 (revision 0)
@@ -0,0 +1,88 @@
+! { 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
+
Index: testsuite/gfortran.dg/transfer_simplify_2.f90
===================================================================
--- testsuite/gfortran.dg/transfer_simplify_2.f90 (revision 0)
+++ testsuite/gfortran.dg/transfer_simplify_2.f90 (revision 0)
@@ -0,0 +1,132 @@
+! { 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 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) = (/asin (1.0_8), log (1.0_8)/)
+ 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 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