Hello world, this new version of the inlie argument packing patch (PR 88821) avoids the ICE on the test case for PR 61968. Otherwise it is unchanged.
Regression-tested. OK for trunk? Regards Thomas 2019-05-11 Thomas Koenig <tkoe...@gcc.gnu.org> PR fortran/88821 * expr.c (gfc_is_simply_contiguous): Return true for an EXPR_ARRAY. * trans-array.c (is_pointer): New function. (gfc_conv_array_parameter): Call gfc_conv_subref_array_arg when not optimizing and not optimizing for size if the formal arg is passed by reference. * trans-expr.c (gfc_conv_subref_array_arg): Add arguments fsym, proc_name and sym. Add run-time warning for temporary array creation. Wrap argument if passing on an optional argument to an optional argument. * trans.h (gfc_conv_subref_array_arg): Add optional arguments fsym, proc_name and sym to prototype. 2019-05-11 Thomas Koenig <tkoe...@gcc.gnu.org> PR fortran/88821 * gfortran.dg/alloc_comp_auto_array_3.f90: Add -O0 to dg-options to make sure the test for internal_pack is retained. * gfortran.dg/assumed_type_2.f90: Split compile and run time tests into this and * gfortran.dg/assumed_type_2a.f90: New file. * gfortran.dg/c_loc_test_22.f90: Likewise. * gfortran.dg/contiguous_3.f90: Likewise. * gfortran.dg/internal_pack_11.f90: Likewise. * gfortran.dg/internal_pack_12.f90: Likewise. * gfortran.dg/internal_pack_16.f90: Likewise. * gfortran.dg/internal_pack_17.f90: Likewise. * gfortran.dg/internal_pack_18.f90: Likewise. * gfortran.dg/internal_pack_4.f90: Likewise. * gfortran.dg/internal_pack_5.f90: Add -O0 to dg-options to make sure the test for internal_pack is retained. * gfortran.dg/internal_pack_6.f90: Split compile and run time tests into this and * gfortran.dg/internal_pack_6a.f90: New file. * gfortran.dg/internal_pack_8.f90: Likewise. * gfortran.dg/missing_optional_dummy_6: Split compile and run time tests into this and * gfortran.dg/missing_optional_dummy_6a.f90: New file. * gfortran.dg/no_arg_check_2.f90: Split compile and run time tests into this and * gfortran.dg/no_arg_check_2a.f90: New file. * gfortran.dg/typebound_assignment_5.f90: Split compile and run time tests into this and * gfortran.dg/typebound_assignment_5a.f90: New file. * gfortran.dg/typebound_assignment_6.f90: Split compile and run time tests into this and * gfortran.dg/typebound_assignment_6a.f90: New file. * gfortran.dg/internal_pack_19.f90: New file. * gfortran.dg/internal_pack_20.f90: New file. * gfortran.dg/internal_pack_21.f90: New file.
Index: fortran/expr.c =================================================================== --- fortran/expr.c (Revision 270622) +++ fortran/expr.c (Arbeitskopie) @@ -5713,6 +5713,9 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool str gfc_ref *ref, *part_ref = NULL; gfc_symbol *sym; + if (expr->expr_type == EXPR_ARRAY) + return true; + if (expr->expr_type == EXPR_FUNCTION) { if (expr->value.function.esym) Index: fortran/trans-array.c =================================================================== --- fortran/trans-array.c (Revision 270622) +++ fortran/trans-array.c (Arbeitskopie) @@ -7869,6 +7869,23 @@ array_parameter_size (tree desc, gfc_expr *expr, t *size, fold_convert (gfc_array_index_type, elem)); } +/* Helper function - return true if the argument is a pointer. */ + +static bool +is_pointer (gfc_expr *e) +{ + gfc_symbol *sym; + + if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL) + return false; + + sym = e->symtree->n.sym; + if (sym == NULL) + return false; + + return sym->attr.pointer || sym->attr.proc_pointer; +} + /* Convert an array for passing as an actual parameter. */ void @@ -8120,6 +8137,20 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * "Creating array temporary at %L", &expr->where); } + /* When optmizing, we can use gfc_conv_subref_array_arg for + making the packing and unpacking operation visible to the + optimizers. */ + + if (g77 && optimize && !optimize_size && expr->expr_type == EXPR_VARIABLE + && !is_pointer (expr) && (fsym == NULL + || fsym->ts.type != BT_ASSUMED)) + { + gfc_conv_subref_array_arg (se, expr, g77, + fsym ? fsym->attr.intent : INTENT_INOUT, + false, fsym, proc_name, sym); + return; + } + ptr = build_call_expr_loc (input_location, gfor_fndecl_in_pack, 1, desc); Index: fortran/trans-expr.c =================================================================== --- fortran/trans-expr.c (Revision 270622) +++ fortran/trans-expr.c (Arbeitskopie) @@ -4576,8 +4576,10 @@ gfc_apply_interface_mapping (gfc_interface_mapping an actual argument derived type array is copied and then returned after the function call. */ void -gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, - sym_intent intent, bool formal_ptr) +gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77, + sym_intent intent, bool formal_ptr, + const gfc_symbol *fsym, const char *proc_name, + gfc_symbol *sym) { gfc_se lse; gfc_se rse; @@ -4594,7 +4596,37 @@ void stmtblock_t body; int n; int dimen; + gfc_se work_se; + gfc_se *parmse; + bool pass_optional; + pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional; + + if (pass_optional) + { + gfc_init_se (&work_se, NULL); + parmse = &work_se; + } + else + parmse = se; + + if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS) + { + /* We will create a temporary array, so let us warn. */ + char * msg; + + if (fsym && proc_name) + msg = xasprintf ("An array temporary was created for argument " + "'%s' of procedure '%s'", fsym->name, proc_name); + else + msg = xasprintf ("An array temporary was created"); + + tmp = build_int_cst (logical_type_node, 1); + gfc_trans_runtime_check (false, true, tmp, &parmse->pre, + &expr->where, msg); + free (msg); + } + gfc_init_se (&lse, NULL); gfc_init_se (&rse, NULL); @@ -4848,6 +4880,53 @@ class_array_fcn: else parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr); + if (pass_optional) + { + tree present; + tree type; + stmtblock_t else_block; + tree pre_stmts, post_stmts; + tree pointer; + tree else_stmt; + + /* Make this into + + if (present (a)) + { + parmse->pre; + optional = parse->expr; + } + else + optional = NULL; + call foo (optional); + if (present (a)) + parmse->post; + + */ + + type = TREE_TYPE (parmse->expr); + pointer = gfc_create_var (type, "optional"); + tmp = gfc_conv_expr_present (sym); + present = gfc_evaluate_now (tmp, &se->pre); + gfc_add_modify (&parmse->pre, pointer, parmse->expr); + pre_stmts = gfc_finish_block (&parmse->pre); + + gfc_init_block (&else_block); + gfc_add_modify (&else_block, pointer, build_int_cst (type, 0)); + else_stmt = gfc_finish_block (&else_block); + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, present, + pre_stmts, else_stmt); + gfc_add_expr_to_block (&se->pre, tmp); + + post_stmts = gfc_finish_block (&parmse->post); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, present, + post_stmts, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se->post, tmp); + + se->expr = pointer; + } + return; } Index: fortran/trans.h =================================================================== --- fortran/trans.h (Revision 270622) +++ fortran/trans.h (Arbeitskopie) @@ -529,7 +529,10 @@ int gfc_is_intrinsic_libcall (gfc_expr *); int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *, gfc_expr *, vec<tree, va_gc> *); -void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool); +void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool, + const gfc_symbol *fsym = NULL, + const char *proc_name = NULL, + gfc_symbol *sym = NULL); /* Generate code for a scalar assignment. */ tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool, Index: testsuite/gfortran.dg/alloc_comp_auto_array_3.f90 =================================================================== --- testsuite/gfortran.dg/alloc_comp_auto_array_3.f90 (Revision 270622) +++ testsuite/gfortran.dg/alloc_comp_auto_array_3.f90 (Arbeitskopie) @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-fdump-tree-original" } +! { dg-options "-O0 -fdump-tree-original" } ! ! Test the fix for PR66082. The original problem was with the first ! call foo_1d. Index: testsuite/gfortran.dg/assumed_type_2.f90 =================================================================== --- testsuite/gfortran.dg/assumed_type_2.f90 (Revision 270622) +++ testsuite/gfortran.dg/assumed_type_2.f90 (Arbeitskopie) @@ -1,5 +1,5 @@ -! { dg-do run } -! { dg-options "-fdump-tree-original" } +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } ! ! PR fortran/48820 ! Index: testsuite/gfortran.dg/c_loc_test_22.f90 =================================================================== --- testsuite/gfortran.dg/c_loc_test_22.f90 (Revision 270622) +++ testsuite/gfortran.dg/c_loc_test_22.f90 (Arbeitskopie) @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-fdump-tree-original" } +! { dg-options "-O0 -fdump-tree-original" } ! ! PR fortran/56907 ! Index: testsuite/gfortran.dg/contiguous_3.f90 =================================================================== --- testsuite/gfortran.dg/contiguous_3.f90 (Revision 270622) +++ testsuite/gfortran.dg/contiguous_3.f90 (Arbeitskopie) @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-fdump-tree-original" } +! { dg-options "-O0 -fdump-tree-original" } ! ! PR fortran/40632 ! Index: testsuite/gfortran.dg/internal_pack_11.f90 =================================================================== --- testsuite/gfortran.dg/internal_pack_11.f90 (Revision 270622) +++ testsuite/gfortran.dg/internal_pack_11.f90 (Arbeitskopie) @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-fdump-tree-original" } +! { dg-options "-O0 -fdump-tree-original" } ! ! Test the fix for PR43173, where unnecessary calls to internal_pack/unpack ! were being produced below. These references are contiguous and so do not Index: testsuite/gfortran.dg/internal_pack_12.f90 =================================================================== --- testsuite/gfortran.dg/internal_pack_12.f90 (Revision 270622) +++ testsuite/gfortran.dg/internal_pack_12.f90 (Arbeitskopie) @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-fdump-tree-original" } +! { dg-options "-O0 -fdump-tree-original" } ! ! Test the fix for PR43243, where unnecessary calls to internal_pack/unpack ! were being produced below. These references are contiguous and so do not Index: testsuite/gfortran.dg/internal_pack_16.f90 =================================================================== --- testsuite/gfortran.dg/internal_pack_16.f90 (Revision 270622) +++ testsuite/gfortran.dg/internal_pack_16.f90 (Arbeitskopie) @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-additional-options "-fdump-tree-original" } +! { dg-additional-options "-O0 -fdump-tree-original" } ! PR 59345 - pack/unpack was not needed here. SUBROUTINE S1(A) REAL :: A(3) Index: testsuite/gfortran.dg/internal_pack_17.f90 =================================================================== --- testsuite/gfortran.dg/internal_pack_17.f90 (Revision 270622) +++ testsuite/gfortran.dg/internal_pack_17.f90 (Arbeitskopie) @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-additional-options "-fdump-tree-original" } +! { dg-additional-options "-O0 -fdump-tree-original" } ! PR 59345 - pack/unpack was not needed here. ! Original test case by Joost VandeVondele SUBROUTINE S1(A) Index: testsuite/gfortran.dg/internal_pack_18.f90 =================================================================== --- testsuite/gfortran.dg/internal_pack_18.f90 (Revision 270622) +++ testsuite/gfortran.dg/internal_pack_18.f90 (Arbeitskopie) @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-additional-options "-fdump-tree-original" } +! { dg-additional-options "-O0 -fdump-tree-original" } ! PR 57992 - this was packed/unpacked unnecessarily. ! Original case by Tobias Burnus. subroutine test Index: testsuite/gfortran.dg/internal_pack_4.f90 =================================================================== --- testsuite/gfortran.dg/internal_pack_4.f90 (Revision 270622) +++ testsuite/gfortran.dg/internal_pack_4.f90 (Arbeitskopie) @@ -1,5 +1,4 @@ ! { dg-do run } -! { dg-options "-fdump-tree-original" } ! ! PR fortran/36132 ! @@ -25,6 +24,3 @@ END MODULE M1 USE M1 CALL S2() END - -! { dg-final { scan-tree-dump-times "a != 0B \\? \\\(.*\\\) _gfortran_internal_pack" 1 "original" } } -! { dg-final { scan-tree-dump-times "if \\(a != 0B &&" 1 "original" } } Index: testsuite/gfortran.dg/internal_pack_5.f90 =================================================================== --- testsuite/gfortran.dg/internal_pack_5.f90 (Revision 270622) +++ testsuite/gfortran.dg/internal_pack_5.f90 (Arbeitskopie) @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-fdump-tree-original" } +! { dg-options "-O0 -fdump-tree-original" } ! ! PR fortran/36909 ! Index: testsuite/gfortran.dg/internal_pack_6.f90 =================================================================== --- testsuite/gfortran.dg/internal_pack_6.f90 (Revision 270622) +++ testsuite/gfortran.dg/internal_pack_6.f90 (Arbeitskopie) @@ -1,5 +1,5 @@ -! { dg-do run } -! { dg-options "-fdump-tree-original" } +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } ! ! Test the fix for PR41113 and PR41117, in which unnecessary calls ! to internal_pack and internal_unpack were being generated. Index: testsuite/gfortran.dg/internal_pack_9.f90 =================================================================== --- testsuite/gfortran.dg/internal_pack_9.f90 (Revision 270622) +++ testsuite/gfortran.dg/internal_pack_9.f90 (Arbeitskopie) @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-fdump-tree-original" } +! { dg-options "-O0 -fdump-tree-original" } ! ! During the discussion of the fix for PR43072, in which unnecessary ! calls to internal PACK/UNPACK were being generated, the following, Index: testsuite/gfortran.dg/missing_optional_dummy_6.f90 =================================================================== --- testsuite/gfortran.dg/missing_optional_dummy_6.f90 (Revision 270622) +++ testsuite/gfortran.dg/missing_optional_dummy_6.f90 (Arbeitskopie) @@ -46,14 +46,3 @@ contains end subroutine scalar2 end program test - -! { dg-final { scan-tree-dump-times "scalar2 \\(slr1" 1 "original" } } - -! { dg-final { scan-tree-dump-times "= es1 != 0B" 1 "original" } } -! { dg-final { scan-tree-dump-times "assumed_shape2 \\(es1" 0 "original" } } -! { dg-final { scan-tree-dump-times "explicit_shape2 \\(es1" 1 "original" } } - -! { dg-final { scan-tree-dump-times "= as1 != 0B" 2 "original" } } -! { dg-final { scan-tree-dump-times "assumed_shape2 \\(as1" 0 "original" } } -! { dg-final { scan-tree-dump-times "explicit_shape2 \\(as1" 0 "original" } } - Index: testsuite/gfortran.dg/no_arg_check_2.f90 =================================================================== --- testsuite/gfortran.dg/no_arg_check_2.f90 (Revision 270622) +++ testsuite/gfortran.dg/no_arg_check_2.f90 (Arbeitskopie) @@ -1,5 +1,5 @@ -! { dg-do run } -! { dg-options "-fdump-tree-original" } +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } ! ! PR fortran/39505 ! Index: testsuite/gfortran.dg/typebound_assignment_5.f03 =================================================================== --- testsuite/gfortran.dg/typebound_assignment_5.f03 (Revision 270622) +++ testsuite/gfortran.dg/typebound_assignment_5.f03 (Arbeitskopie) @@ -1,5 +1,5 @@ -! { dg-do run } -! { dg-options "-fdump-tree-original" } +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } ! ! PR fortran/49074 ! ICE on defined assignment with class arrays. Index: testsuite/gfortran.dg/typebound_assignment_6.f03 =================================================================== --- testsuite/gfortran.dg/typebound_assignment_6.f03 (Revision 270622) +++ testsuite/gfortran.dg/typebound_assignment_6.f03 (Arbeitskopie) @@ -1,5 +1,4 @@ ! { dg-do run } -! { dg-options "-fdump-tree-original" } ! ! PR fortran/56136 ! ICE on defined assignment with class arrays. @@ -37,6 +36,3 @@ IF (ANY(A(2::2)%I /= (/ ((50+2*I, I=1,SIZE(A)/4), J=1,2) /))) STOP 3 END PROGRAM -! { dg-final { scan-tree-dump-times "_gfortran_internal_pack" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_internal_unpack" 1 "original" } } -
! { dg-do run } ! { dg-options "-O -fdump-tree-original" } ! Test handling of the optional argument. MODULE M1 INTEGER, PARAMETER :: dp=KIND(0.0D0) CONTAINS SUBROUTINE S1(a) REAL(dp), DIMENSION(45), INTENT(OUT), & OPTIONAL :: a if (present(a)) STOP 1 END SUBROUTINE S1 SUBROUTINE S2(a) REAL(dp), DIMENSION(:, :), INTENT(OUT), & OPTIONAL :: a CALL S1(a) END SUBROUTINE END MODULE M1 USE M1 CALL S2() END ! { dg-final { scan-tree-dump-times "optional" 4 "original" } } ! { dg-final { scan-tree-dump-not "_gfortran_internal_unpack" "original" } }
! { dg-do compile } ! { dg-options "-O -fdump-tree-original" } ! Check that internal_pack is not called with -O. module x implicit none contains subroutine bar(a, n) integer, intent(in) :: n integer, intent(in), dimension(n) :: a print *,a end subroutine bar end module x program main use x implicit none integer, parameter :: n = 10 integer, dimension(n) :: a integer :: i a = [(i,i=1,n)] call bar(a(n:1:-1),n) end program main ! { dg-final { scan-tree-dump-not "_gfortran_internal_pack" "original" } }
! { dg-do compile } ! { dg-options "-Os -fdump-tree-original" } ! Check that internal_pack is called with -Os. module x implicit none contains subroutine bar(a, n) integer, intent(in) :: n integer, intent(in), dimension(n) :: a print *,a end subroutine bar end module x program main use x implicit none integer, parameter :: n = 10 integer, dimension(n) :: a integer :: i a = [(i,i=1,n)] call bar(a(n:1:-1),n) end program main ! { dg-final { scan-tree-dump-times "_gfortran_internal_pack" 1 "original" } }
! { dg-do compile } ! { dg-options "-O0 -fdump-tree-original" } ! ! PR fortran/41907 ! program test implicit none call scalar1 () call assumed_shape1 () call explicit_shape1 () contains ! Calling functions subroutine scalar1 (slr1) integer, optional :: slr1 call scalar2 (slr1) end subroutine scalar1 subroutine assumed_shape1 (as1) integer, dimension(:), optional :: as1 call assumed_shape2 (as1) call explicit_shape2 (as1) end subroutine assumed_shape1 subroutine explicit_shape1 (es1) integer, dimension(5), optional :: es1 call assumed_shape2 (es1) call explicit_shape2 (es1) end subroutine explicit_shape1 ! Called functions subroutine assumed_shape2 (as2) integer, dimension(:),optional :: as2 if (present (as2)) STOP 1 end subroutine assumed_shape2 subroutine explicit_shape2 (es2) integer, dimension(5),optional :: es2 if (present (es2)) STOP 2 end subroutine explicit_shape2 subroutine scalar2 (slr2) integer, optional :: slr2 if (present (slr2)) STOP 3 end subroutine scalar2 end program test ! { dg-final { scan-tree-dump-times "scalar2 \\(slr1" 1 "original" } } ! { dg-final { scan-tree-dump-times "= es1 != 0B" 1 "original" } } ! { dg-final { scan-tree-dump-times "assumed_shape2 \\(es1" 0 "original" } } ! { dg-final { scan-tree-dump-times "explicit_shape2 \\(es1" 1 "original" } } ! { dg-final { scan-tree-dump-times "= as1 != 0B" 2 "original" } } ! { dg-final { scan-tree-dump-times "assumed_shape2 \\(as1" 0 "original" } } ! { dg-final { scan-tree-dump-times "explicit_shape2 \\(as1" 0 "original" } }
! { dg-do compile } ! { dg-options "-O0 -fdump-tree-original" } ! ! PR fortran/56136 ! ICE on defined assignment with class arrays. ! ! Original testcase by Alipasha <alipash.cele...@gmail.com> MODULE A_TEST_M TYPE :: A_TYPE INTEGER :: I CONTAINS GENERIC :: ASSIGNMENT (=) => ASGN_A PROCEDURE, PRIVATE :: ASGN_A END TYPE CONTAINS ELEMENTAL SUBROUTINE ASGN_A (A, B) CLASS (A_TYPE), INTENT (INOUT) :: A CLASS (A_TYPE), INTENT (IN) :: B A%I = B%I END SUBROUTINE END MODULE A_TEST_M PROGRAM ASGN_REALLOC_TEST USE A_TEST_M TYPE (A_TYPE), ALLOCATABLE :: A(:) INTEGER :: I, J ALLOCATE (A(100)) A = (/ (A_TYPE(I), I=1,SIZE(A)) /) A(1:50) = A(51:100) IF (ANY(A%I /= (/ ((50+I, I=1,SIZE(A)/2), J=1,2) /))) STOP 1 A(::2) = A(1:50) ! pack/unpack IF (ANY(A( ::2)%I /= (/ (50+I, I=1,SIZE(A)/2) /))) STOP 2 IF (ANY(A(2::2)%I /= (/ ((50+2*I, I=1,SIZE(A)/4), J=1,2) /))) STOP 3 END PROGRAM ! { dg-final { scan-tree-dump-times "_gfortran_internal_pack" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_internal_unpack" 1 "original" } }
! { dg-do run } ! ! PR fortran/49074 ! ICE on defined assignment with class arrays. module foo type bar integer :: i contains generic :: assignment (=) => assgn_bar procedure, private :: assgn_bar end type bar contains elemental subroutine assgn_bar (a, b) class (bar), intent (inout) :: a class (bar), intent (in) :: b select type (b) type is (bar) a%i = b%i end select return end subroutine assgn_bar end module foo program main use foo type (bar), allocatable :: foobar(:) allocate (foobar(2)) foobar = [bar(1), bar(2)] if (any(foobar%i /= [1, 2])) STOP 1 end program
! { dg-do run } ! ! PR fortran/39505 ! ! Test NO_ARG_CHECK ! Copied from assumed_type_2.f90 ! module mod use iso_c_binding, only: c_loc, c_ptr, c_bool implicit none interface my_c_loc function my_c_loc1(x) bind(C) import c_ptr !GCC$ attributes NO_ARG_CHECK :: x type(*) :: x type(c_ptr) :: my_c_loc1 end function end interface my_c_loc contains subroutine sub_scalar (arg1, presnt) integer(8), target, optional :: arg1 logical :: presnt type(c_ptr) :: cpt !GCC$ attributes NO_ARG_CHECK :: arg1 if (presnt .neqv. present (arg1)) STOP 1 cpt = c_loc (arg1) end subroutine sub_scalar subroutine sub_array_assumed (arg3) !GCC$ attributes NO_ARG_CHECK :: arg3 logical(1), target :: arg3(*) type(c_ptr) :: cpt cpt = c_loc (arg3) end subroutine sub_array_assumed end module use mod use iso_c_binding, only: c_int, c_null_ptr implicit none type t1 integer :: a end type t1 type :: t2 sequence integer :: b end type t2 type, bind(C) :: t3 integer(c_int) :: c end type t3 integer :: scalar_int real, allocatable :: scalar_real_alloc character, pointer :: scalar_char_ptr integer :: array_int(3) real, allocatable :: array_real_alloc(:,:) character, pointer :: array_char_ptr(:,:) type(t1) :: scalar_t1 type(t2), allocatable :: scalar_t2_alloc type(t3), pointer :: scalar_t3_ptr type(t1) :: array_t1(4) type(t2), allocatable :: array_t2_alloc(:,:) type(t3), pointer :: array_t3_ptr(:,:) class(t1), allocatable :: scalar_class_t1_alloc class(t1), pointer :: scalar_class_t1_ptr class(t1), allocatable :: array_class_t1_alloc(:,:) class(t1), pointer :: array_class_t1_ptr(:,:) scalar_char_ptr => null() scalar_t3_ptr => null() call sub_scalar (presnt=.false.) call sub_scalar (scalar_real_alloc, .false.) call sub_scalar (scalar_char_ptr, .false.) call sub_scalar (null (), .false.) call sub_scalar (scalar_t2_alloc, .false.) call sub_scalar (scalar_t3_ptr, .false.) allocate (scalar_real_alloc, scalar_char_ptr, scalar_t3_ptr) allocate (scalar_class_t1_alloc, scalar_class_t1_ptr, scalar_t2_alloc) allocate (array_real_alloc(3:5,2:4), array_char_ptr(-2:2,2)) allocate (array_t2_alloc(3:5,2:4), array_t3_ptr(-2:2,2)) allocate (array_class_t1_alloc(3,3), array_class_t1_ptr(4,4)) call sub_scalar (scalar_int, .true.) call sub_scalar (scalar_real_alloc, .true.) call sub_scalar (scalar_char_ptr, .true.) call sub_scalar (array_int(2), .true.) call sub_scalar (array_real_alloc(3,2), .true.) call sub_scalar (array_char_ptr(0,1), .true.) call sub_scalar (scalar_t1, .true.) call sub_scalar (scalar_t2_alloc, .true.) call sub_scalar (scalar_t3_ptr, .true.) call sub_scalar (array_t1(2), .true.) call sub_scalar (array_t2_alloc(3,2), .true.) call sub_scalar (array_t3_ptr(0,1), .true.) call sub_scalar (array_class_t1_alloc(2,1), .true.) call sub_scalar (array_class_t1_ptr(3,3), .true.) call sub_array_assumed (array_int) call sub_array_assumed (array_real_alloc) call sub_array_assumed (array_char_ptr) call sub_array_assumed (array_t1) call sub_array_assumed (array_t2_alloc) call sub_array_assumed (array_t3_ptr) call sub_array_assumed (array_class_t1_alloc) call sub_array_assumed (array_class_t1_ptr) deallocate (scalar_char_ptr, scalar_class_t1_ptr, array_char_ptr) deallocate (array_class_t1_ptr, array_t3_ptr) contains subroutine sub(x) integer :: x(:) call sub_array_assumed (x) end subroutine sub end
! { dg-do run } ! ! Test the fix for PR41113 and PR41117, in which unnecessary calls ! to internal_pack and internal_unpack were being generated. ! ! Contributed by Joost VandeVondele <jv...@cam.ac.uk> ! MODULE M1 TYPE T1 REAL :: data(10) = [(i, i = 1, 10)] END TYPE T1 CONTAINS SUBROUTINE S1(data, i, chksum) REAL, DIMENSION(*) :: data integer :: i, j real :: subsum, chksum subsum = 0 do j = 1, i subsum = subsum + data(j) end do if (abs(subsum - chksum) > 1e-6) STOP 1 END SUBROUTINE S1 END MODULE SUBROUTINE S2 use m1 TYPE(T1) :: d real :: data1(10) = [(i, i = 1, 10)] REAL :: data(-4:5,-4:5) = reshape ([(real(i), i = 1, 100)], [10,10]) ! PR41113 CALL S1(d%data, 10, sum (d%data)) CALL S1(data1, 10, sum (data1)) ! PR41117 DO i=-4,5 CALL S1(data(:,i), 10, sum (data(:,i))) ENDDO ! With the fix for PR41113/7 this is the only time that _internal_pack ! was called. The final part of the fix for PR43072 put paid to it too. DO i=-4,5 CALL S1(data(-2:,i), 8, sum (data(-2:,i))) ENDDO DO i=-4,4 CALL S1(data(:,i:i+1), 20, sum (reshape (data(:,i:i+1), [20]))) ENDDO DO i=-4,5 CALL S1(data(2,i), 1, data(2,i)) ENDDO END SUBROUTINE S2 call s2 end
! { dg-do run } ! ! PR fortran/48820 ! ! Test TYPE(*) ! module mod use iso_c_binding, only: c_loc, c_ptr, c_bool implicit none interface my_c_loc function my_c_loc1(x) bind(C) import c_ptr type(*) :: x type(c_ptr) :: my_c_loc1 end function function my_c_loc2(x) bind(C) import c_ptr type(*) :: x(*) type(c_ptr) :: my_c_loc2 end function end interface my_c_loc contains subroutine sub_scalar (arg1, presnt) type(*), target, optional :: arg1 logical :: presnt type(c_ptr) :: cpt if (presnt .neqv. present (arg1)) STOP 1 cpt = c_loc (arg1) end subroutine sub_scalar subroutine sub_array_shape (arg2, lbounds, ubounds) type(*), target :: arg2(:,:) type(c_ptr) :: cpt integer :: lbounds(2), ubounds(2) if (any (lbound(arg2) /= lbounds)) STOP 2 if (any (ubound(arg2) /= ubounds)) STOP 3 if (any (shape(arg2) /= ubounds-lbounds+1)) STOP 4 if (size(arg2) /= product (ubounds-lbounds+1)) STOP 5 if (rank (arg2) /= 2) STOP 6 ! if (.not. is_continuous (arg2)) STOP 7 !<< Not yet implemented ! cpt = c_loc (arg2) ! << FIXME: Valid since TS29113 call sub_array_assumed (arg2) end subroutine sub_array_shape subroutine sub_array_assumed (arg3) type(*), target :: arg3(*) type(c_ptr) :: cpt cpt = c_loc (arg3) end subroutine sub_array_assumed end module use mod use iso_c_binding, only: c_int, c_null_ptr implicit none type t1 integer :: a end type t1 type :: t2 sequence integer :: b end type t2 type, bind(C) :: t3 integer(c_int) :: c end type t3 integer :: scalar_int real, allocatable :: scalar_real_alloc character, pointer :: scalar_char_ptr integer :: array_int(3) real, allocatable :: array_real_alloc(:,:) character, pointer :: array_char_ptr(:,:) type(t1) :: scalar_t1 type(t2), allocatable :: scalar_t2_alloc type(t3), pointer :: scalar_t3_ptr type(t1) :: array_t1(4) type(t2), allocatable :: array_t2_alloc(:,:) type(t3), pointer :: array_t3_ptr(:,:) class(t1), allocatable :: scalar_class_t1_alloc class(t1), pointer :: scalar_class_t1_ptr class(t1), allocatable :: array_class_t1_alloc(:,:) class(t1), pointer :: array_class_t1_ptr(:,:) scalar_char_ptr => null() scalar_t3_ptr => null() call sub_scalar (presnt=.false.) call sub_scalar (scalar_real_alloc, .false.) call sub_scalar (scalar_char_ptr, .false.) call sub_scalar (null (), .false.) call sub_scalar (scalar_t2_alloc, .false.) call sub_scalar (scalar_t3_ptr, .false.) allocate (scalar_real_alloc, scalar_char_ptr, scalar_t3_ptr) allocate (scalar_class_t1_alloc, scalar_class_t1_ptr, scalar_t2_alloc) allocate (array_real_alloc(3:5,2:4), array_char_ptr(-2:2,2)) allocate (array_t2_alloc(3:5,2:4), array_t3_ptr(-2:2,2)) allocate (array_class_t1_alloc(3,3), array_class_t1_ptr(4,4)) call sub_scalar (scalar_int, .true.) call sub_scalar (scalar_real_alloc, .true.) call sub_scalar (scalar_char_ptr, .true.) call sub_scalar (array_int(2), .true.) call sub_scalar (array_real_alloc(3,2), .true.) call sub_scalar (array_char_ptr(0,1), .true.) call sub_scalar (scalar_t1, .true.) call sub_scalar (scalar_t2_alloc, .true.) call sub_scalar (scalar_t3_ptr, .true.) call sub_scalar (array_t1(2), .true.) call sub_scalar (array_t2_alloc(3,2), .true.) call sub_scalar (array_t3_ptr(0,1), .true.) call sub_scalar (array_class_t1_alloc(2,1), .true.) call sub_scalar (array_class_t1_ptr(3,3), .true.) call sub_array_assumed (array_int) call sub_array_assumed (array_real_alloc) call sub_array_assumed (array_char_ptr) call sub_array_assumed (array_t1) call sub_array_assumed (array_t2_alloc) call sub_array_assumed (array_t3_ptr) call sub_array_assumed (array_class_t1_alloc) call sub_array_assumed (array_class_t1_ptr) call sub_array_shape (array_real_alloc, [1,1], shape(array_real_alloc)) call sub_array_shape (array_char_ptr, [1,1], shape(array_char_ptr)) call sub_array_shape (array_t2_alloc, [1,1], shape(array_t2_alloc)) call sub_array_shape (array_t3_ptr, [1,1], shape(array_t3_ptr)) call sub_array_shape (array_class_t1_alloc, [1,1], shape(array_class_t1_alloc)) call sub_array_shape (array_class_t1_ptr, [1,1], shape(array_class_t1_ptr)) deallocate (scalar_char_ptr, scalar_class_t1_ptr, array_char_ptr) deallocate (array_class_t1_ptr, array_t3_ptr) end