+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.
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 \
# 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)
#include "gfortran.h"
#include "arith.h"
#include "intrinsic.h"
+#include "target-memory.h"
gfc_expr gfc_bad_expr;
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;
}
--- /dev/null
+/* 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;
+}
--- /dev/null
+/* 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 */
+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.
--- /dev/null
+! { 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
--- /dev/null
+! { 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
projects / thirdparty / gcc.git / commitdiff
