From 8572fdb47edb67c0157ce7857e004758fa653f46 Mon Sep 17 00:00:00 2001 From: domob Date: Tue, 29 Jul 2008 09:11:51 +0000 Subject: [PATCH] 2008-07-29 Daniel Kraft 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 PR fortran/36403 * gfortran.dg/char_eoshift_5.f90: New test. * gfortran.dg/intrinsic_optional_char_arg_1.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@138234 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 9 +++ gcc/fortran/trans-intrinsic.c | 83 +++++++++++++++++++++- gcc/testsuite/ChangeLog | 6 ++ gcc/testsuite/gfortran.dg/char_eoshift_5.f90 | 24 +++++++ .../gfortran.dg/intrinsic_optional_char_arg_1.f90 | 31 ++++++++ 5 files changed, 152 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/char_eoshift_5.f90 create mode 100644 gcc/testsuite/gfortran.dg/intrinsic_optional_char_arg_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 720626302f3..b15bcfb7ade 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2008-07-29 Daniel Kraft + + 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 * gfortran.h (try): Remove macro. Replace try with gfc_try diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index a56f4c1fabb..bbb129dbdcd 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index dc2bb162abf..e6ec66ef5ba 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2008-07-29 Daniel Kraft + + 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 Merge from gimple-tuples-branch. diff --git a/gcc/testsuite/gfortran.dg/char_eoshift_5.f90 b/gcc/testsuite/gfortran.dg/char_eoshift_5.f90 new file mode 100644 index 00000000000..93c701a4f1b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/char_eoshift_5.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/intrinsic_optional_char_arg_1.f90 b/gcc/testsuite/gfortran.dg/intrinsic_optional_char_arg_1.f90 new file mode 100644 index 00000000000..5352ee4bf26 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intrinsic_optional_char_arg_1.f90 @@ -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" } } -- 2.11.0