This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [patch, fortran] Implement constant-folding for TRANSFER intrinsic.
Tobi,
Please find enclosed a patch that I believe remedies that which was
wrong....
Or do you merely mean that the "NULL" part should be omitted, and the
earlier version of it should be written as "!size" rather than as
"size != NULL"? That makes sense.
The latter, sorry for the confusion.
done
My suggestion may also break with zero source_sizes, so I think we
should stay with yours.
indeed
What about targets with different character sets?
They are currently hypothetical; even the S390 is only currently
supported in an ASCII configuration as far as I can tell.
It's a valid concern beyond that, but I'm not sure what to do with it.
I thought the S390 used EBCDIC unconditionally, if that's not the
case, I agree that it's not a real problem.
You are right... I have tried to forget EBCDIC for a long time.... and
S390s. Let's wait and see if it is a real problem. The testcase
compares transfers made via the front and the middle-end, so they should
not depend on the character set. I think that I am right in saying that
any other form of test would not be portable. Remember that TRANSFER is
a very odd beast - it actually rejoices in converting one type bitwise
to another. Thus, anything that depends on changing characters to
something else cannot, by definition, be character set independent.
My inclination would be to do the cosmetic and small fixes to this
and go ahead and commit it and then work on the
alternate-character-set hypotheticality and the derived-type spacing
stuff in follow-up patches, since AFAIK this doesn't cause anything
to break that worked previously. But that's not a strong
inclination, and I'll let Paul and FX make the call on that. :)
I agree.
I think we should assert that we're not dealing with derived types,
since otherwise we would leave the user with a potentially
hard-to-find error. Apart from that, I agree with this course of action.
I have fixed derived types. Instead of assuming that the derived types
are packed, I have used gfc_typenode_for_spec to produce a tree type and
then use the offset values in the components. I believe that this is
robust.
Various other bits and pieces have been done, as you suggested - alloca,
MAX etc., etc.
I have added some complex tests but have not yet got around to the
REAL(10 + x) tests. I propose to do a transfer_simplify_3.f90 just as
soon as I have a moment.
Unless somebody objects, I will commit to trunk tomorrow morning.
Thanks for the review, Tobi
Paul
PS I wrote a skeleton for this patch that was completely target
dependent and something of an organisational disaster. Brooks then took
it, did the middle-end mods and cleaned up my mess. Many thanks to
Brooks for all of that.
Index: gcc/fortran/Make-lang.in
===================================================================
*** gcc/fortran/Make-lang.in (revision 124723)
--- gcc/fortran/Make-lang.in (working copy)
*************** F95_PARSER_OBJS = fortran/arith.o fortra
*** 66,72 ****
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
F95_OBJS = $(F95_PARSER_OBJS) \
fortran/convert.o fortran/dependency.o fortran/f95-lang.o \
--- 66,72 ----
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/target-memory.o
F95_OBJS = $(F95_PARSER_OBJS) \
fortran/convert.o fortran/dependency.o fortran/f95-lang.o \
*************** fortran.stagefeedback: stageprofile-star
*** 297,303 ****
# TODO: Add dependencies on the backend/tree header files
$(F95_PARSER_OBJS): fortran/gfortran.h fortran/intrinsic.h fortran/match.h \
! fortran/parse.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)
--- 297,303 ----
# 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/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: gcc/fortran/target-memory.c
===================================================================
*** gcc/fortran/target-memory.c (revision 0)
--- gcc/fortran/target-memory.c (revision 0)
***************
*** 0 ****
--- 1,458 ----
+ /* 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)
+ {
+ 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;
+ gfc_component *cmp;
+ int ptr = 0;
+ 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));
+ ptr += 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. */
+ 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;
+ 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));
+ ptr += 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;
+ }
Index: gcc/fortran/target-memory.h
===================================================================
*** gcc/fortran/target-memory.h (revision 0)
--- gcc/fortran/target-memory.h (revision 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: gcc/fortran/simplify.c
===================================================================
*** gcc/fortran/simplify.c (revision 124723)
--- gcc/fortran/simplify.c (working copy)
*************** Software Foundation, 51 Franklin Street,
*** 26,31 ****
--- 26,32 ----
#include "gfortran.h"
#include "arith.h"
#include "intrinsic.h"
+ #include "target-memory.h"
gfc_expr gfc_bad_expr;
*************** gfc_simplify_tiny (gfc_expr *e)
*** 3865,3876 ****
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);
! return NULL;
}
--- 3866,3946 ----
gfc_expr *
gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
{
! 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;
!
! /* 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;
}
Index: gcc/testsuite/gfortran.dg/transfer_simplify_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/transfer_simplify_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/transfer_simplify_1.f90 (revision 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
Index: gcc/testsuite/gfortran.dg/transfer_simplify_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/transfer_simplify_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/transfer_simplify_2.f90 (revision 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