re PR fortran/36403 (Some fortran tests using eoshift fail on SH)
2008-07-29 Daniel Kraft <d@domob.eu> PR fortran/36403 * trans-intrinsic.c (conv_generic_with_optional_char_arg): New method to append a string-length even if the string argument is missing, e.g. for EOSHIFT. (gfc_conv_intrinsic_function): Call the new method for EOSHIFT, PACK and RESHAPE. 2008-07-29 Daniel Kraft <d@domob.eu> PR fortran/36403 * gfortran.dg/char_eoshift_5.f90: New test. * gfortran.dg/intrinsic_optional_char_arg_1.f90: New test. From-SVN: r138234
This commit is contained in:
parent
8c54989af5
commit
1fbfb0e27a
|
@ -1,3 +1,12 @@
|
|||
2008-07-29 Daniel Kraft <d@domob.eu>
|
||||
|
||||
PR fortran/36403
|
||||
* trans-intrinsic.c (conv_generic_with_optional_char_arg): New method
|
||||
to append a string-length even if the string argument is missing, e.g.
|
||||
for EOSHIFT.
|
||||
(gfc_conv_intrinsic_function): Call the new method for EOSHIFT, PACK
|
||||
and RESHAPE.
|
||||
|
||||
2008-07-28 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
|
||||
|
||||
* gfortran.h (try): Remove macro. Replace try with gfc_try
|
||||
|
|
|
@ -2652,6 +2652,64 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
|
|||
se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
|
||||
}
|
||||
|
||||
|
||||
/* Process an intrinsic with unspecified argument-types that has an optional
|
||||
argument (which could be of type character), e.g. EOSHIFT. For those, we
|
||||
need to append the string length of the optional argument if it is not
|
||||
present and the type is really character.
|
||||
primary specifies the position (starting at 1) of the non-optional argument
|
||||
specifying the type and optional gives the position of the optional
|
||||
argument in the arglist. */
|
||||
|
||||
static void
|
||||
conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
|
||||
unsigned primary, unsigned optional)
|
||||
{
|
||||
gfc_actual_arglist* prim_arg;
|
||||
gfc_actual_arglist* opt_arg;
|
||||
unsigned cur_pos;
|
||||
gfc_actual_arglist* arg;
|
||||
gfc_symbol* sym;
|
||||
tree append_args;
|
||||
|
||||
/* Find the two arguments given as position. */
|
||||
cur_pos = 0;
|
||||
prim_arg = NULL;
|
||||
opt_arg = NULL;
|
||||
for (arg = expr->value.function.actual; arg; arg = arg->next)
|
||||
{
|
||||
++cur_pos;
|
||||
|
||||
if (cur_pos == primary)
|
||||
prim_arg = arg;
|
||||
if (cur_pos == optional)
|
||||
opt_arg = arg;
|
||||
|
||||
if (cur_pos >= primary && cur_pos >= optional)
|
||||
break;
|
||||
}
|
||||
gcc_assert (prim_arg);
|
||||
gcc_assert (prim_arg->expr);
|
||||
gcc_assert (opt_arg);
|
||||
|
||||
/* If we do have type CHARACTER and the optional argument is really absent,
|
||||
append a dummy 0 as string length. */
|
||||
append_args = NULL_TREE;
|
||||
if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
|
||||
{
|
||||
tree dummy;
|
||||
|
||||
dummy = build_int_cst (gfc_charlen_type_node, 0);
|
||||
append_args = gfc_chainon_list (append_args, dummy);
|
||||
}
|
||||
|
||||
/* Build the call itself. */
|
||||
sym = gfc_get_symbol_for_expr (expr);
|
||||
gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
|
||||
gfc_free (sym);
|
||||
}
|
||||
|
||||
|
||||
/* The length of a character string. */
|
||||
static void
|
||||
gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
|
||||
|
@ -4128,7 +4186,22 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
|||
{
|
||||
if (lib == 1)
|
||||
se->ignore_optional = 1;
|
||||
gfc_conv_intrinsic_funcall (se, expr);
|
||||
|
||||
switch (expr->value.function.isym->id)
|
||||
{
|
||||
case GFC_ISYM_EOSHIFT:
|
||||
case GFC_ISYM_PACK:
|
||||
case GFC_ISYM_RESHAPE:
|
||||
/* For all of those the first argument specifies the type and the
|
||||
third is optional. */
|
||||
conv_generic_with_optional_char_arg (se, expr, 1, 3);
|
||||
break;
|
||||
|
||||
default:
|
||||
gfc_conv_intrinsic_funcall (se, expr);
|
||||
break;
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
@ -4606,6 +4679,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
|||
gfc_conv_intrinsic_funcall (se, expr);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_EOSHIFT:
|
||||
case GFC_ISYM_PACK:
|
||||
case GFC_ISYM_RESHAPE:
|
||||
/* For those, expr->rank should always be >0 and thus the if above the
|
||||
switch should have matched. */
|
||||
gcc_unreachable ();
|
||||
break;
|
||||
|
||||
default:
|
||||
gfc_conv_intrinsic_lib_function (se, expr);
|
||||
break;
|
||||
|
|
|
@ -1,3 +1,9 @@
|
|||
2008-07-29 Daniel Kraft <d@domob.eu>
|
||||
|
||||
PR fortran/36403
|
||||
* gfortran.dg/char_eoshift_5.f90: New test.
|
||||
* gfortran.dg/intrinsic_optional_char_arg_1.f90: New test.
|
||||
|
||||
2008-07-28 Richard Guenther <rguenther@suse.de>
|
||||
|
||||
Merge from gimple-tuples-branch.
|
||||
|
|
|
@ -0,0 +1,24 @@
|
|||
! { dg-do run }
|
||||
! { dg-options "-fdump-tree-original" }
|
||||
|
||||
! PR fortran/36403
|
||||
! Check that the string length of BOUNDARY is added to the library-eoshift
|
||||
! call even if BOUNDARY is missing (as it is optional).
|
||||
! This is the original test from the PR.
|
||||
|
||||
! Contributed by Kazumoto Kojima.
|
||||
|
||||
CHARACTER(LEN=3), DIMENSION(10) :: Z
|
||||
call test_eoshift
|
||||
contains
|
||||
subroutine test_eoshift
|
||||
CHARACTER(LEN=1), DIMENSION(10) :: chk
|
||||
chk(1:8) = "5"
|
||||
chk(9:10) = " "
|
||||
Z(:)="456"
|
||||
if (any (EOSHIFT(Z(:)(2:2),2) .ne. chk)) call abort
|
||||
END subroutine
|
||||
END
|
||||
|
||||
! Check that _gfortran_eoshift* is called with 8 arguments:
|
||||
! { dg-final { scan-tree-dump "_gfortran_eoshift\[0-9_\]+char \\(\[&a-zA-Z0-9._\]*, \[&a-zA-Z0-9._\]*, \[&a-zA-Z0-9._\]*, \[&a-zA-Z0-9._\]*, \[&a-zA-Z0-9._\]*, \[&a-zA-Z0-9._\]*, \[&a-zA-Z0-9._\]*, \[&a-zA-Z0-9._\]*\\)" "original" } }
|
|
@ -0,0 +1,31 @@
|
|||
! { dg-do compile }
|
||||
! { dg-options "-fdump-tree-original" }
|
||||
|
||||
! PR fortran/36403
|
||||
! Check that string lengths of optional arguments are added to the library-call
|
||||
! even if those arguments are missing.
|
||||
|
||||
PROGRAM main
|
||||
IMPLICIT NONE
|
||||
|
||||
CHARACTER(len=1) :: vect(4)
|
||||
CHARACTER(len=1) :: matrix(2, 2)
|
||||
|
||||
matrix(1, 1) = ""
|
||||
matrix(2, 1) = "a"
|
||||
matrix(1, 2) = "b"
|
||||
matrix(2, 2) = ""
|
||||
vect = (/ "w", "x", "y", "z" /)
|
||||
|
||||
! Call the affected intrinsics
|
||||
vect = EOSHIFT (vect, 2)
|
||||
vect = PACK (matrix, matrix /= "")
|
||||
matrix = RESHAPE (vect, (/ 2, 2 /))
|
||||
|
||||
END PROGRAM main
|
||||
|
||||
! All library function should be called with *two* trailing arguments "1" for
|
||||
! the string lengths of both the main array and the optional argument:
|
||||
! { dg-final { scan-tree-dump "_eoshift\[0-9_\]+char \\(\[&a-zA-Z0-9._, \]+, 1, 0\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "_reshape\[0-9_\]+char \\(\[&a-zA-Z0-9._, \]+, 1, 0\\)" "original" } }
|
||||
! { dg-final { scan-tree-dump "_pack\[0-9_\]+char \\(\[&a-zA-Z0-9._, \]+, 1, 0\\)" "original" } }
|
Loading…
Reference in New Issue