Commit 1fbfb0e2 by Daniel Kraft Committed by Daniel Kraft

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
parent 8c54989a
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> 2008-07-28 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
* gfortran.h (try): Remove macro. Replace try with gfc_try * gfortran.h (try): Remove macro. Replace try with gfc_try
......
...@@ -2652,6 +2652,64 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) ...@@ -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); 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. */ /* The length of a character string. */
static void static void
gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
...@@ -4128,7 +4186,22 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) ...@@ -4128,7 +4186,22 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
{ {
if (lib == 1) if (lib == 1)
se->ignore_optional = 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; return;
} }
} }
...@@ -4606,6 +4679,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) ...@@ -4606,6 +4679,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_funcall (se, expr); gfc_conv_intrinsic_funcall (se, expr);
break; 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: default:
gfc_conv_intrinsic_lib_function (se, expr); gfc_conv_intrinsic_lib_function (se, expr);
break; break;
......
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> 2008-07-28 Richard Guenther <rguenther@suse.de>
Merge from gimple-tuples-branch. Merge from gimple-tuples-branch.
......
! { 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" } }
! { 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" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment