re PR testsuite/26981 (g++.old-deja/g++.other/init18.C fails)
2006-04-03 Paul Thomas <pault@gcc.gnu.org> PR fortran/26981 * trans.h : Prototype for gfc_conv_missing_dummy. * trans-expr (gfc_conv_missing_dummy): New function (gfc_conv_function_call): Call it and tidy up some of the code. * trans-intrinsic (gfc_conv_intrinsic_function_args): The same. PR fortran/26976 * array.c (gfc_array_dimen_size): If available, return shape[dimen]. * resolve.c (resolve_function): If available, use the argument shape for the function expression. * iresolve.c (gfc_resolve_transfer): Set shape[0] = size. 2006-04-03 Paul Thomas <pault@gcc.gnu.org> PR fortran/26981 * gfortran.dg/missing_optional_dummy_1.f90: New test. PR fortran/26976 * gfortran.dg/compliant_elemental_intrinsics_1.f90: New test. * gfortran.dg/initialization_1.f90: Make assignment compliant. * gfortran.dg/transfer_array_intrinsic_1.f90: Simplify. * gfortran.dg/transfer_array_intrinsic_2.f90: Make assignments compliant and detect bigendian-ness. From-SVN: r112634
This commit is contained in:
Paul Thomas
parent
b6f65e3c5d
commit
e15e9be3a8
|
|
@ -1,3 +1,17 @@
|
|||
2006-04-03 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/26981
|
||||
* trans.h : Prototype for gfc_conv_missing_dummy.
|
||||
* trans-expr (gfc_conv_missing_dummy): New function
|
||||
(gfc_conv_function_call): Call it and tidy up some of the code.
|
||||
* trans-intrinsic (gfc_conv_intrinsic_function_args): The same.
|
||||
|
||||
PR fortran/26976
|
||||
* array.c (gfc_array_dimen_size): If available, return shape[dimen].
|
||||
* resolve.c (resolve_function): If available, use the argument shape for the
|
||||
function expression.
|
||||
* iresolve.c (gfc_resolve_transfer): Set shape[0] = size.
|
||||
|
||||
2006-04-02 Erik Edelmann <eedelman@gcc.gnu.org>
|
||||
|
||||
* trans-array.c (gfc_trans_dealloc_allocated): Take a
|
||||
|
|
|
|||
|
|
@ -1872,6 +1872,12 @@ gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result)
|
|||
}
|
||||
}
|
||||
|
||||
if (array->shape && array->shape[dimen])
|
||||
{
|
||||
mpz_init_set (*result, array->shape[dimen]);
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
|
|
|
|||
|
|
@ -1955,6 +1955,11 @@ gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
|
|||
{
|
||||
f->rank = 1;
|
||||
f->value.function.name = transfer1;
|
||||
if (size && gfc_is_constant_expr (size))
|
||||
{
|
||||
f->shape = gfc_get_shape (1);
|
||||
mpz_init_set (f->shape[0], size->value.integer);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -1205,6 +1205,7 @@ resolve_function (gfc_expr * expr)
|
|||
const char *name;
|
||||
try t;
|
||||
int temp;
|
||||
int i;
|
||||
|
||||
sym = NULL;
|
||||
if (expr->symtree)
|
||||
|
|
@ -1304,6 +1305,12 @@ resolve_function (gfc_expr * expr)
|
|||
if (arg->expr != NULL && arg->expr->rank > 0)
|
||||
{
|
||||
expr->rank = arg->expr->rank;
|
||||
if (!expr->shape && arg->expr->shape)
|
||||
{
|
||||
expr->shape = gfc_get_shape (expr->rank);
|
||||
for (i = 0; i < expr->rank; i++)
|
||||
mpz_init_set (expr->shape[i], arg->expr->shape[i]);
|
||||
}
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -142,6 +142,31 @@ gfc_conv_expr_present (gfc_symbol * sym)
|
|||
}
|
||||
|
||||
|
||||
/* Converts a missing, dummy argument into a null or zero. */
|
||||
|
||||
void
|
||||
gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts)
|
||||
{
|
||||
tree present;
|
||||
tree tmp;
|
||||
|
||||
present = gfc_conv_expr_present (arg->symtree->n.sym);
|
||||
tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
|
||||
convert (TREE_TYPE (se->expr), integer_zero_node));
|
||||
tmp = gfc_evaluate_now (tmp, &se->pre);
|
||||
se->expr = tmp;
|
||||
if (ts.type == BT_CHARACTER)
|
||||
{
|
||||
tmp = convert (gfc_charlen_type_node, integer_zero_node);
|
||||
tmp = build3 (COND_EXPR, gfc_charlen_type_node, present,
|
||||
se->string_length, tmp);
|
||||
tmp = gfc_evaluate_now (tmp, &se->pre);
|
||||
se->string_length = tmp;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
/* Get the character length of an expression, looking through gfc_refs
|
||||
if necessary. */
|
||||
|
||||
|
|
@ -1805,6 +1830,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
bool callee_alloc;
|
||||
gfc_typespec ts;
|
||||
gfc_charlen cl;
|
||||
gfc_expr *e;
|
||||
gfc_symbol *fsym;
|
||||
|
||||
arglist = NULL_TREE;
|
||||
retargs = NULL_TREE;
|
||||
|
|
@ -1844,7 +1871,9 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
/* Evaluate the arguments. */
|
||||
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
|
||||
{
|
||||
if (arg->expr == NULL)
|
||||
e = arg->expr;
|
||||
fsym = formal ? formal->sym : NULL;
|
||||
if (e == NULL)
|
||||
{
|
||||
|
||||
if (se->ignore_optional)
|
||||
|
|
@ -1872,19 +1901,19 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
{
|
||||
/* An elemental function inside a scalarized loop. */
|
||||
gfc_init_se (&parmse, se);
|
||||
gfc_conv_expr_reference (&parmse, arg->expr);
|
||||
gfc_conv_expr_reference (&parmse, e);
|
||||
}
|
||||
else
|
||||
{
|
||||
/* A scalar or transformational function. */
|
||||
gfc_init_se (&parmse, NULL);
|
||||
argss = gfc_walk_expr (arg->expr);
|
||||
argss = gfc_walk_expr (e);
|
||||
|
||||
if (argss == gfc_ss_terminator)
|
||||
{
|
||||
gfc_conv_expr_reference (&parmse, arg->expr);
|
||||
if (formal && formal->sym->attr.pointer
|
||||
&& arg->expr->expr_type != EXPR_NULL)
|
||||
gfc_conv_expr_reference (&parmse, e);
|
||||
if (fsym && fsym->attr.pointer
|
||||
&& e->expr_type != EXPR_NULL)
|
||||
{
|
||||
/* Scalar pointer dummy args require an extra level of
|
||||
indirection. The null pointer already contains
|
||||
|
|
@ -1901,27 +1930,27 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
convention, and pass the address of the array descriptor
|
||||
instead. Otherwise we use g77's calling convention. */
|
||||
int f;
|
||||
f = (formal != NULL)
|
||||
&& !(formal->sym->attr.pointer || formal->sym->attr.allocatable)
|
||||
&& formal->sym->as->type != AS_ASSUMED_SHAPE;
|
||||
f = (fsym != NULL)
|
||||
&& !(fsym->attr.pointer || fsym->attr.allocatable)
|
||||
&& fsym->as->type != AS_ASSUMED_SHAPE;
|
||||
f = f || !sym->attr.always_explicit;
|
||||
if (arg->expr->expr_type == EXPR_VARIABLE
|
||||
&& is_aliased_array (arg->expr))
|
||||
if (e->expr_type == EXPR_VARIABLE
|
||||
&& is_aliased_array (e))
|
||||
/* The actual argument is a component reference to an
|
||||
array of derived types. In this case, the argument
|
||||
is converted to a temporary, which is passed and then
|
||||
written back after the procedure call. */
|
||||
gfc_conv_aliased_arg (&parmse, arg->expr, f);
|
||||
gfc_conv_aliased_arg (&parmse, e, f);
|
||||
else
|
||||
gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
|
||||
gfc_conv_array_parameter (&parmse, e, argss, f);
|
||||
|
||||
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
|
||||
allocated on entry, it must be deallocated. */
|
||||
if (formal && formal->sym->attr.allocatable
|
||||
&& formal->sym->attr.intent == INTENT_OUT)
|
||||
if (fsym && fsym->attr.allocatable
|
||||
&& fsym->attr.intent == INTENT_OUT)
|
||||
{
|
||||
tmp = arg->expr->symtree->n.sym->backend_decl;
|
||||
if (arg->expr->symtree->n.sym->attr.dummy)
|
||||
tmp = e->symtree->n.sym->backend_decl;
|
||||
if (e->symtree->n.sym->attr.dummy)
|
||||
tmp = build_fold_indirect_ref (tmp);
|
||||
tmp = gfc_trans_dealloc_allocated (tmp);
|
||||
gfc_add_expr_to_block (&se->pre, tmp);
|
||||
|
|
@ -1930,8 +1959,15 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
}
|
||||
}
|
||||
|
||||
if (formal && need_interface_mapping)
|
||||
gfc_add_interface_mapping (&mapping, formal->sym, &parmse);
|
||||
/* If an optional argument is itself an optional dummy argument,
|
||||
check its presence and substitute a null if absent. */
|
||||
if (e && e->expr_type == EXPR_VARIABLE
|
||||
&& e->symtree->n.sym->attr.optional
|
||||
&& fsym && fsym->attr.optional)
|
||||
gfc_conv_missing_dummy (&parmse, e, fsym->ts);
|
||||
|
||||
if (fsym && need_interface_mapping)
|
||||
gfc_add_interface_mapping (&mapping, fsym, &parmse);
|
||||
|
||||
gfc_add_block_to_block (&se->pre, &parmse.pre);
|
||||
gfc_add_block_to_block (&se->post, &parmse.post);
|
||||
|
|
|
|||
|
|
@ -165,28 +165,42 @@ static tree
|
|||
gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
|
||||
{
|
||||
gfc_actual_arglist *actual;
|
||||
tree args;
|
||||
gfc_expr *e;
|
||||
gfc_intrinsic_arg *formal;
|
||||
gfc_se argse;
|
||||
tree args;
|
||||
|
||||
args = NULL_TREE;
|
||||
for (actual = expr->value.function.actual; actual; actual = actual->next)
|
||||
formal = expr->value.function.isym->formal;
|
||||
|
||||
for (actual = expr->value.function.actual; actual; actual = actual->next,
|
||||
formal = formal ? formal->next : NULL)
|
||||
{
|
||||
e = actual->expr;
|
||||
/* Skip omitted optional arguments. */
|
||||
if (!actual->expr)
|
||||
if (!e)
|
||||
continue;
|
||||
|
||||
/* Evaluate the parameter. This will substitute scalarized
|
||||
references automatically. */
|
||||
gfc_init_se (&argse, se);
|
||||
|
||||
if (actual->expr->ts.type == BT_CHARACTER)
|
||||
if (e->ts.type == BT_CHARACTER)
|
||||
{
|
||||
gfc_conv_expr (&argse, actual->expr);
|
||||
gfc_conv_expr (&argse, e);
|
||||
gfc_conv_string_parameter (&argse);
|
||||
args = gfc_chainon_list (args, argse.string_length);
|
||||
}
|
||||
else
|
||||
gfc_conv_expr_val (&argse, actual->expr);
|
||||
gfc_conv_expr_val (&argse, e);
|
||||
|
||||
/* If an optional argument is itself an optional dummy argument,
|
||||
check its presence and substitute a null if absent. */
|
||||
if (e->expr_type ==EXPR_VARIABLE
|
||||
&& e->symtree->n.sym->attr.optional
|
||||
&& formal
|
||||
&& formal->optional)
|
||||
gfc_conv_missing_dummy (&argse, e, formal->ts);
|
||||
|
||||
gfc_add_block_to_block (&se->pre, &argse.pre);
|
||||
gfc_add_block_to_block (&se->post, &argse.post);
|
||||
|
|
|
|||
|
|
@ -317,6 +317,8 @@ void gfc_conv_structure (gfc_se *, gfc_expr *, int);
|
|||
|
||||
/* Return an expression which determines if a dummy parameter is present. */
|
||||
tree gfc_conv_expr_present (gfc_symbol *);
|
||||
/* Convert a missing, dummy argument into a null or zero. */
|
||||
void gfc_conv_missing_dummy (gfc_se *, gfc_expr *, gfc_typespec);
|
||||
|
||||
/* Generate code to allocate a string temporary. */
|
||||
tree gfc_conv_string_tmp (gfc_se *, tree, tree);
|
||||
|
|
|
|||
|
|
@ -1,3 +1,15 @@
|
|||
2006-04-03 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/26981
|
||||
* gfortran.dg/missing_optional_dummy_1.f90: New test.
|
||||
|
||||
PR fortran/26976
|
||||
* gfortran.dg/compliant_elemental_intrinsics_1.f90: New test.
|
||||
* gfortran.dg/initialization_1.f90: Make assignment compliant.
|
||||
* gfortran.dg/transfer_array_intrinsic_1.f90: Simplify.
|
||||
* gfortran.dg/transfer_array_intrinsic_2.f90: Make assignments compliant and detect
|
||||
bigendian-ness.
|
||||
|
||||
2006-04-02 Erik Edelmann <eedelman@gcc.gnu.org>
|
||||
|
||||
* gfortran.dg/allocatable_dummy_1.f90: Also check that allocatable
|
||||
|
|
|
|||
|
|
@ -0,0 +1,26 @@
|
|||
! { dg-do compile }
|
||||
! Tests the fix for PR26976, in which non-compliant elemental
|
||||
! intrinsic function results were not detected. At the same
|
||||
! time, the means to tests the compliance of TRANSFER with the
|
||||
! optional SIZE parameter was added.
|
||||
!
|
||||
! Contributed by Dominique Dhumieres <dominiq@lps.ens.fr>
|
||||
!
|
||||
real(4) :: pi, a(2), b(3)
|
||||
character(26) :: ch
|
||||
|
||||
pi = acos(-1.0)
|
||||
b = pi
|
||||
|
||||
a = cos(b) ! { dg-error "different shape for Array assignment" }
|
||||
|
||||
a = -pi
|
||||
b = cos(a) ! { dg-error "different shape for Array assignment" }
|
||||
|
||||
ch = "abcdefghijklmnopqrstuvwxyz"
|
||||
a = transfer (ch, pi, 3) ! { dg-error "different shape for Array assignment" }
|
||||
|
||||
! This already generated an error
|
||||
b = reshape ((/1.0/),(/1/)) ! { dg-error "different shape for Array assignment" }
|
||||
|
||||
end
|
||||
|
|
@ -21,6 +21,7 @@ contains
|
|||
real(8) :: x (1:2, *)
|
||||
real(8) :: y (0:,:)
|
||||
integer :: i
|
||||
real :: z(2, 2)
|
||||
|
||||
! However, this gives a warning because it is an initialization expression.
|
||||
integer :: l1 = len (ch1) ! { dg-warning "assumed character length variable" }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,49 @@
|
|||
! { dg-do run }
|
||||
! Test the fix for PR26891, in which an optional argument, whose actual
|
||||
! is a missing dummy argument would cause a segfault.
|
||||
!
|
||||
! Contributed by Paul Thomas <pault@gcc.gnu.org>
|
||||
!
|
||||
logical :: back =.false.
|
||||
|
||||
! This was the case that would fail - PR case was an intrinsic call.
|
||||
if (scan ("A quick brown fox jumps over the lazy dog", "lazy", back) &
|
||||
.ne. myscan ("A quick brown fox jumps over the lazy dog", "lazy")) &
|
||||
call abort ()
|
||||
|
||||
! Check that the patch works with non-intrinsic functions.
|
||||
if (myscan ("A quick brown fox jumps over the lazy dog", "fox", back) &
|
||||
.ne. thyscan ("A quick brown fox jumps over the lazy dog", "fox")) &
|
||||
call abort ()
|
||||
|
||||
! Check that missing, optional character actual arguments are OK.
|
||||
if (scan ("A quick brown fox jumps over the lazy dog", "over", back) &
|
||||
.ne. thyscan ("A quick brown fox jumps over the lazy dog")) &
|
||||
call abort ()
|
||||
|
||||
contains
|
||||
integer function myscan (str, substr, back)
|
||||
character(*), intent(in) :: str, substr
|
||||
logical, optional, intent(in) :: back
|
||||
myscan = scan (str, substr, back)
|
||||
end function myscan
|
||||
|
||||
integer function thyscan (str, substr, back)
|
||||
character(*), intent(in) :: str
|
||||
character(*), optional, intent(in) :: substr
|
||||
logical, optional, intent(in) :: back
|
||||
thyscan = isscan (str, substr, back)
|
||||
end function thyscan
|
||||
|
||||
integer function isscan (str, substr, back)
|
||||
character(*), intent(in) :: str
|
||||
character(*), optional :: substr
|
||||
logical, optional, intent(in) :: back
|
||||
if (.not.present(substr)) then
|
||||
isscan = myscan (str, "over", back)
|
||||
else
|
||||
isscan = myscan (str, substr, back)
|
||||
end if
|
||||
end function isscan
|
||||
|
||||
end
|
||||
|
|
@ -1,22 +1,11 @@
|
|||
! { dg-do run { target i?86-*-* x86_64-*-* } }
|
||||
! { dg-do run }
|
||||
! Tests the patch to implement the array version of the TRANSFER
|
||||
! intrinsic (PR17298).
|
||||
! Contributed by Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/)
|
||||
|
||||
! tests numeric transfers(including PR testcase).
|
||||
! test the PR is fixed.
|
||||
|
||||
call test1 ()
|
||||
|
||||
! tests numeric/character transfers.
|
||||
|
||||
call test2 ()
|
||||
|
||||
! Test dummies, automatic objects and assumed character length.
|
||||
|
||||
call test3 (ch, ch, ch, 8)
|
||||
|
||||
contains
|
||||
|
||||
subroutine test1 ()
|
||||
|
|
@ -29,90 +18,6 @@ contains
|
|||
cmp = transfer (z, cmp) * 2.0
|
||||
if (any (cmp .ne. (/2.0, 4.0/))) call abort ()
|
||||
|
||||
! Check that size smaller than the source word length is OK.
|
||||
|
||||
z = (-1.0, -2.0)
|
||||
cmp = transfer (z, cmp, 1) * 8.0
|
||||
if (any (cmp .ne. (/-8.0, 4.0/))) call abort ()
|
||||
|
||||
! Check multi-dimensional sources and that transfer works as an actual
|
||||
! argument of reshape.
|
||||
|
||||
a = reshape ((/(rand (), i = 1, 16)/), (/4,4/))
|
||||
jt = transfer (a, it)
|
||||
it = reshape (jt, (/4, 2, 4/))
|
||||
if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort ()
|
||||
|
||||
end subroutine test1
|
||||
|
||||
subroutine test2 ()
|
||||
integer(4) :: y(4), z(2)
|
||||
character(4) :: ch(4)
|
||||
y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) &
|
||||
+ ishft (i + 3, 24), i = 65, 80 , 4)/)
|
||||
|
||||
! Check source array sections in both directions.
|
||||
|
||||
ch = "wxyz"
|
||||
ch = transfer (y(2:4:2), ch)
|
||||
if (any (ch .ne. (/"EFGH","MNOP","wxyz","wxyz"/))) call abort ()
|
||||
ch = "wxyz"
|
||||
ch = transfer (y(4:2:-2), ch)
|
||||
if (any (ch .ne. (/"MNOP","EFGH","wxyz","wxyz"/))) call abort ()
|
||||
|
||||
! Check that a complete array transfers with size absent.
|
||||
|
||||
ch = transfer (y, ch)
|
||||
if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort ()
|
||||
|
||||
! Check that a character array section is OK
|
||||
|
||||
z = transfer (ch(2:3), y)
|
||||
if (any (z .ne. y(2:3))) call abort ()
|
||||
|
||||
! Check dest array sections in both directions.
|
||||
|
||||
ch = "wxyz"
|
||||
ch(3:4) = transfer (y, ch, 2)
|
||||
if (any (ch .ne. (/"wxyz","wxyz","ABCD","EFGH"/))) call abort ()
|
||||
ch = "wxyz"
|
||||
ch(3:2:-1) = transfer (y, ch, 3)
|
||||
if (any (ch .ne. (/"wxyz","EFGH","ABCD","wxyz"/))) call abort ()
|
||||
|
||||
! Check that too large a value of size is cut off.
|
||||
|
||||
ch = "wxyz"
|
||||
ch(1:2) = transfer (y, ch, 3)
|
||||
if (any (ch .ne. (/"ABCD","EFGH","wxyz","wxyz"/))) call abort ()
|
||||
|
||||
! Make sure that character to numeric is OK.
|
||||
|
||||
z = transfer (ch, y)
|
||||
if (any (y(1:2) .ne. z)) call abort ()
|
||||
|
||||
end subroutine test2
|
||||
|
||||
subroutine test3 (ch1, ch2, ch3, clen)
|
||||
integer clen
|
||||
character(8) :: ch1(:)
|
||||
character(*) :: ch2(2)
|
||||
character(clen) :: ch3(2)
|
||||
character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/)
|
||||
integer(8) :: ic(2)
|
||||
ic = transfer (cntrl, ic)
|
||||
|
||||
! Check assumed shape.
|
||||
|
||||
if (any (ic .ne. transfer (ch1, ic))) call abort ()
|
||||
|
||||
! Check assumed character length.
|
||||
|
||||
if (any (ic .ne. transfer (ch2, ic))) call abort ()
|
||||
|
||||
! Check automatic character length.
|
||||
|
||||
if (any (ic .ne. transfer (ch3, ic))) call abort ()
|
||||
|
||||
end subroutine test3
|
||||
|
||||
end
|
||||
|
|
|
|||
|
|
@ -1,23 +1,119 @@
|
|||
! { dg-do run { target i?86-*-* x86_64-*-* } }
|
||||
! { dg-options "-fpack-derived" }
|
||||
call test3()
|
||||
! { dg-do run }
|
||||
! Tests the patch to implement the array version of the TRANSFER
|
||||
! intrinsic (PR17298).
|
||||
! Contributed by Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
! Bigendian test posted by Perseus in comp.lang.fortran on 4 July 2005.
|
||||
! Original had parameter but this fails, at present, if is_gimple_var with -Ox, x>0
|
||||
|
||||
LOGICAL :: bigend
|
||||
integer :: icheck = 1
|
||||
|
||||
character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/)
|
||||
|
||||
bigend = IACHAR(TRANSFER(icheck,"a")) == 0
|
||||
|
||||
! tests numeric transfers other than original testscase.
|
||||
|
||||
call test1 ()
|
||||
|
||||
! tests numeric/character transfers.
|
||||
|
||||
call test2 ()
|
||||
|
||||
! Test dummies, automatic objects and assumed character length.
|
||||
|
||||
call test3 (ch, ch, ch, 8)
|
||||
|
||||
contains
|
||||
subroutine test3 ()
|
||||
type mytype
|
||||
sequence
|
||||
real(8) :: x = 3.14159
|
||||
character(4) :: ch = "wxyz"
|
||||
integer(2) :: i = 77
|
||||
end type mytype
|
||||
type(mytype) :: z(2)
|
||||
character(1) :: c(32)
|
||||
character(4) :: chr
|
||||
real(8) :: a
|
||||
integer(2) :: l
|
||||
equivalence (a, c(15)), (chr, c(23)), (l, c(27))
|
||||
c = transfer(z, c)
|
||||
if (a .ne. z(1)%x) call abort ()
|
||||
if (chr .ne. z(1)%ch) call abort ()
|
||||
if (l .ne. z(1)%i) call abort ()
|
||||
end subroutine test3
|
||||
|
||||
subroutine test1 ()
|
||||
real(4) :: a(4, 4)
|
||||
integer(2) :: it(4, 2, 4), jt(32)
|
||||
|
||||
! Check multi-dimensional sources and that transfer works as an actual
|
||||
! argument of reshape.
|
||||
|
||||
a = reshape ((/(rand (), i = 1, 16)/), (/4,4/))
|
||||
jt = transfer (a, it)
|
||||
it = reshape (jt, (/4, 2, 4/))
|
||||
if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort ()
|
||||
|
||||
end subroutine test1
|
||||
|
||||
subroutine test2 ()
|
||||
integer(4) :: y(4), z(2)
|
||||
character(4) :: ch(4)
|
||||
|
||||
! Allow for endian-ness
|
||||
if (bigend) then
|
||||
y = (/(i + 3 + ishft (i + 2, 8) + ishft (i + 1, 16) &
|
||||
+ ishft (i, 24), i = 65, 80 , 4)/)
|
||||
else
|
||||
y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) &
|
||||
+ ishft (i + 3, 24), i = 65, 80 , 4)/)
|
||||
end if
|
||||
|
||||
! Check source array sections in both directions.
|
||||
|
||||
ch = "wxyz"
|
||||
ch(1:2) = transfer (y(2:4:2), ch)
|
||||
if (any (ch(1:2) .ne. (/"EFGH","MNOP"/))) call abort ()
|
||||
ch = "wxyz"
|
||||
ch(1:2) = transfer (y(4:2:-2), ch)
|
||||
if (any (ch(1:2) .ne. (/"MNOP","EFGH"/))) call abort ()
|
||||
|
||||
! Check that a complete array transfers with size absent.
|
||||
|
||||
ch = transfer (y, ch)
|
||||
if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort ()
|
||||
|
||||
! Check that a character array section is OK
|
||||
|
||||
z = transfer (ch(2:3), y)
|
||||
if (any (z .ne. y(2:3))) call abort ()
|
||||
|
||||
! Check dest array sections in both directions.
|
||||
|
||||
ch = "wxyz"
|
||||
ch(3:4) = transfer (y, ch, 2)
|
||||
if (any (ch(3:4) .ne. (/"ABCD","EFGH"/))) call abort ()
|
||||
ch = "wxyz"
|
||||
ch(3:2:-1) = transfer (y, ch, 2)
|
||||
if (any (ch(2:3) .ne. (/"EFGH","ABCD"/))) call abort ()
|
||||
|
||||
! Make sure that character to numeric is OK.
|
||||
|
||||
ch = "wxyz"
|
||||
ch(1:2) = transfer (y, ch, 2)
|
||||
if (any (ch(1:2) .ne. (/"ABCD","EFGH"/))) call abort ()
|
||||
|
||||
z = transfer (ch, y)
|
||||
if (any (y(1:2) .ne. z)) call abort ()
|
||||
|
||||
end subroutine test2
|
||||
|
||||
subroutine test3 (ch1, ch2, ch3, clen)
|
||||
integer clen
|
||||
character(8) :: ch1(:)
|
||||
character(*) :: ch2(2)
|
||||
character(clen) :: ch3(2)
|
||||
character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/)
|
||||
integer(8) :: ic(2)
|
||||
ic = transfer (cntrl, ic)
|
||||
|
||||
! Check assumed shape.
|
||||
|
||||
if (any (ic .ne. transfer (ch1, ic))) call abort ()
|
||||
|
||||
! Check assumed character length.
|
||||
|
||||
if (any (ic .ne. transfer (ch2, ic))) call abort ()
|
||||
|
||||
! Check automatic character length.
|
||||
|
||||
if (any (ic .ne. transfer (ch3, ic))) call abort ()
|
||||
|
||||
end subroutine test3
|
||||
|
||||
end
|
||||
|
|
|
|||
Loading…
Reference in New Issue