diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index f6ef5c023bf0..bffe0808dffe 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -6662,6 +6662,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, symbol_attribute attr; char *msg; tree cond; + tree tmp; if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION) attr = gfc_expr_attr (e); @@ -6732,11 +6733,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else goto end_pointer_check; - tmp = parmse.expr; + if (fsym && fsym->ts.type == BT_CLASS) + { + tmp = build_fold_indirect_ref_loc (input_location, + parmse.expr); + tmp = gfc_class_data_get (tmp); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_conv_descriptor_data_get (tmp); + } + else + tmp = parmse.expr; /* If the argument is passed by value, we need to strip the INDIRECT_REF. */ - if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr))) + if (!POINTER_TYPE_P (TREE_TYPE (tmp))) tmp = gfc_build_addr_expr (NULL_TREE, tmp); cond = fold_build2_loc (input_location, EQ_EXPR, diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 9cf3642f694d..5e53d1162fad 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -8006,8 +8006,10 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) { symbol_attribute attr; char *msg; + tree temp; + tree cond; - attr = gfc_expr_attr (e); + attr = sym ? sym->attr : gfc_expr_attr (e); if (attr.allocatable) msg = xasprintf ("Allocatable argument '%s' is not allocated", e->symtree->n.sym->name); @@ -8017,14 +8019,24 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) else goto end_arg_check; - argse.descriptor_only = 1; - gfc_conv_expr_descriptor (&argse, actual->expr); - tree temp = gfc_conv_descriptor_data_get (argse.expr); - tree cond = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, temp, - fold_convert (TREE_TYPE (temp), - null_pointer_node)); + if (sym) + { + temp = gfc_class_data_get (sym->backend_decl); + temp = gfc_conv_descriptor_data_get (temp); + } + else + { + argse.descriptor_only = 1; + gfc_conv_expr_descriptor (&argse, actual->expr); + temp = gfc_conv_descriptor_data_get (argse.expr); + } + + cond = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, temp, + fold_convert (TREE_TYPE (temp), + null_pointer_node)); gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg); + free (msg); } end_arg_check: diff --git a/gcc/testsuite/gfortran.dg/pr99112.f90 b/gcc/testsuite/gfortran.dg/pr99112.f90 new file mode 100644 index 000000000000..94010615b837 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr99112.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fcheck=pointer -fdump-tree-original" } +! PR99112 - ICE with runtime diagnostics for SIZE intrinsic function + +module m + type t + end type +contains + function f (x, y) result(z) + class(t) :: x(:) + class(t) :: y(size(x)) + type(t) :: z(size(x)) + end + function g (x) result(z) + class(*) :: x(:) + type(t) :: z(size(x)) + end + subroutine s () + class(t), allocatable :: a(:), b(:), c(:), d(:) + class(t), pointer :: p(:) + c = f (a, b) + d = g (p) + end +end +! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 3 "original" } } +! { dg-final { scan-tree-dump-times "Allocatable actual argument" 2 "original" } } +! { dg-final { scan-tree-dump-times "Pointer actual argument" 1 "original" } }