diff options
| -rw-r--r-- | gcc/fortran/trans-expr.cc | 9 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/missing_optional_dummy_7.f90 | 64 |
2 files changed, 73 insertions, 0 deletions
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index bfe9996..6a47af3 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -1365,6 +1365,15 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, tmp = build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, tmp2); gfc_add_expr_to_block (&parmse->pre, tmp); + + if (!elemental && full_array && copyback) + { + tmp2 = build_empty_stmt (input_location); + tmp = gfc_finish_block (&parmse->post); + tmp = build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, tmp2); + gfc_add_expr_to_block (&parmse->post, tmp); + } } else gfc_add_block_to_block (&parmse->pre, &block); diff --git a/gcc/testsuite/gfortran.dg/missing_optional_dummy_7.f90 b/gcc/testsuite/gfortran.dg/missing_optional_dummy_7.f90 new file mode 100644 index 0000000..ad9ecd8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/missing_optional_dummy_7.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! PR fortran/112772 - test absent OPTIONAL, ALLOCATABLE/POINTER class dummies + +program main + implicit none + type t + end type t + call test_c_a () + call test_u_a () + call test_c_p () + call test_u_p () +contains + ! class, allocatable + subroutine test_c_a (msg1) + class(t), optional, allocatable :: msg1(:) + if (present (msg1)) stop 1 + call assert_c_a () + call assert_c_a (msg1) + end + + subroutine assert_c_a (msg2) + class(t), optional, allocatable :: msg2(:) + if (present (msg2)) stop 2 + end + + ! unlimited polymorphic, allocatable + subroutine test_u_a (msg1) + class(*), optional, allocatable :: msg1(:) + if (present (msg1)) stop 3 + call assert_u_a () + call assert_u_a (msg1) + end + + subroutine assert_u_a (msg2) + class(*), optional, allocatable :: msg2(:) + if (present (msg2)) stop 4 + end + + ! class, pointer + subroutine test_c_p (msg1) + class(t), optional, pointer :: msg1(:) + if (present (msg1)) stop 5 + call assert_c_p () + call assert_c_p (msg1) + end + + subroutine assert_c_p (msg2) + class(t), optional, pointer :: msg2(:) + if (present (msg2)) stop 6 + end + + ! unlimited polymorphic, pointer + subroutine test_u_p (msg1) + class(*), optional, pointer :: msg1(:) + if (present (msg1)) stop 7 + call assert_u_p () + call assert_u_p (msg1) + end + + subroutine assert_u_p (msg2) + class(*), optional, pointer :: msg2(:) + if (present (msg2)) stop 8 + end +end |