OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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-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.

From-SVN: r124759
This commit is contained in:
Paul Thomas 2007-05-16 05:40:51 +00:00
parent 9847030dba
commit 7433458d87
8 changed files with 831 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
gcc/fortran/ChangeLog
View File

@ -1,3 +1,17 @@
2007-05-16 Brooks Moses <brooks.moses@codesourcery.com>
PR fortran/18769
PR fortran/30881
PR fortran/31194
PR fortran/31216
PR fortran/31427
* target-memory.c: New file.
* target-memory.h: New file.
* simplify.c: Add #include "target-memory.h".
(gfc_simplify_transfer): Implement constant-
folding for TRANSFER intrinsic.
* Make-lang.in: Add dependencies on new target-memory.* files.
2007-05-15 Paul Brook <paul@codesourcery.com>
* trans-types.c (gfc_type_for_size): Handle signed TImode.

4
gcc/fortran/Make-lang.in
View File

@ -66,7 +66,7 @@ F95_PARSER_OBJS = fortran/arith.o fortran/array.o fortran/bbt.o \
fortran/match.o fortran/matchexp.o fortran/misc.o fortran/module.o \
fortran/openmp.o fortran/options.o fortran/parse.o fortran/primary.o \
fortran/resolve.o fortran/scanner.o fortran/simplify.o fortran/st.o \
fortran/symbol.o
fortran/symbol.o fortran/target-memory.o
F95_OBJS = $(F95_PARSER_OBJS) \
fortran/convert.o fortran/dependency.o fortran/f95-lang.o \
@ -297,7 +297,7 @@ fortran.stagefeedback: stageprofile-start
# TODO: Add dependencies on the backend/tree header files
$(F95_PARSER_OBJS): fortran/gfortran.h fortran/intrinsic.h fortran/match.h \
fortran/parse.h \
fortran/parse.h fortran/arith.h fortran/target-memory.h \
$(CONFIG_H) $(SYSTEM_H) $(TM_H) $(TM_P_H) coretypes.h \
$(RTL_H) $(TREE_H) $(TREE_DUMP_H) $(GGC_H) $(EXPR_H) \
$(FLAGS_H) output.h $(DIAGNOSTIC_H) errors.h $(FUNCTION_H)

80
gcc/fortran/simplify.c
View File

@ -26,6 +26,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
#include "gfortran.h"
#include "arith.h"
#include "intrinsic.h"
#include "target-memory.h"
gfc_expr gfc_bad_expr;
@ -3865,12 +3866,81 @@ gfc_simplify_tiny (gfc_expr *e)
gfc_expr *
gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
{
/* Reference mold and size to suppress warning. */
if (gfc_init_expr && (mold || size))
gfc_error ("TRANSFER intrinsic not implemented for initialization at %L",
&source->where);
gfc_expr *result;
gfc_expr *mold_element;
size_t source_size;
size_t result_size;
size_t result_elt_size;
size_t buffer_size;
mpz_t tmp;
unsigned char *buffer;
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;
}

451
gcc/fortran/target-memory.c Normal file
View File

@ -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;
}

37
gcc/fortran/target-memory.h Normal file
View File

@ -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 */

10
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,13 @@
2007-05-16 Paul Thomas <pault@gcc.gnu.org>
PR fortran/18769
PR fortran/30881
PR fortran/31194
PR fortran/31216
PR fortran/31427
* transfer_simplify_1.f90: New test.
* transfer_simplify_2.f90: New test.
2007-05-15 Dominique d'Humieres <dominiq@lps.ens.fr>
* gfortran.dg/unf_io_convert_3.f90: Fix dg directive.

87
gcc/testsuite/gfortran.dg/transfer_simplify_1.f90 Normal file
View File

@ -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

155
gcc/testsuite/gfortran.dg/transfer_simplify_2.f90 Normal file
View File

@ -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