From 7433458d871f6bfe2169b9d7d04fec64bb142924 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Wed, 16 May 2007 05:40:51 +0000 Subject: [PATCH] [multiple changes] 2007-05-16 Brooks Moses 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 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 | 14 + gcc/fortran/Make-lang.in | 4 +- gcc/fortran/simplify.c | 80 +++- gcc/fortran/target-memory.c | 451 ++++++++++++++++++ gcc/fortran/target-memory.h | 37 ++ gcc/testsuite/ChangeLog | 10 + .../gfortran.dg/transfer_simplify_1.f90 | 87 ++++ .../gfortran.dg/transfer_simplify_2.f90 | 155 ++++++ 8 files changed, 831 insertions(+), 7 deletions(-) create mode 100644 gcc/fortran/target-memory.c create mode 100644 gcc/fortran/target-memory.h create mode 100644 gcc/testsuite/gfortran.dg/transfer_simplify_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/transfer_simplify_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 83a808d15c7..d89c888bc8a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2007-05-16 Brooks Moses + + 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 * trans-types.c (gfc_type_for_size): Handle signed TImode. diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in index 4c707716b42..f9053dc519e 100644 --- a/gcc/fortran/Make-lang.in +++ b/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) diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index ed62ee34da4..87fe6f14708 100644 --- a/gcc/fortran/simplify.c +++ b/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; - 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) + { + 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 index 00000000000..ba2363adf9c --- /dev/null +++ b/gcc/fortran/target-memory.c @@ -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 index 00000000000..85ae552aec3 --- /dev/null +++ b/gcc/fortran/target-memory.h @@ -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 */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1bb53a6a788..ee74a8f7fc0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,13 @@ +2007-05-16 Paul Thomas + + 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 * 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 index 00000000000..c1b241fb99d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_simplify_1.f90 @@ -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 +! + 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 +! + 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 +! + 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 +! + 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 +! + 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 index 00000000000..8f0380af9d2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_simplify_2.f90 @@ -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