------- Comment #3 from pault at gcc dot gnu dot org 2007-05-04 07:29 -------
This fixes it but needs some cleaning up:
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 124354)
--- gcc/fortran/trans-expr.c (working copy)
*************** conv_arglist_function (gfc_se *se, gfc_e
*** 1987,1992 ****
--- 1987,2068 ----
}
+ /* Convert an array valued actual argument expression. */
+
+ static void
+ gfc_conv_array_arg (gfc_se *se, gfc_se *parmse, gfc_ss *argss,
+ gfc_expr *e, gfc_symbol *sym, gfc_symbol *fsym)
+ {
+ /* If the procedure requires an explicit interface, the actual argument
+ is passed according to the corresponding formal argument. If the
+ corresponding formal argument is a POINTER, ALLOCATABLE or assumed
+ shape, we do not use g77's calling convention, and pass the address
+ of the array descriptor instead. Otherwise we use g77's calling
+ convention. */
+ tree tmp;
+ tree parent;
+ gfc_symbol *psym;
+ int f;
+
+ if (e->expr_type == EXPR_VARIABLE)
+ psym = e->symtree->n.sym;
+ else
+ psym = NULL;
+
+ parent = DECL_CONTEXT (current_function_decl);
+
+ f = (fsym != NULL)
+ && !(fsym->attr.pointer || fsym->attr.allocatable)
+ && fsym->as->type != AS_ASSUMED_SHAPE;
+ f = f || !sym->attr.always_explicit;
+
+ /* The actual argument is a component reference to an array of derived
+ types. In this case, the argument is converted to a temporary,
+ which is passed and then written back after the procedure call. */
+ if (e->expr_type == EXPR_VARIABLE && is_aliased_array (e))
+ gfc_conv_aliased_arg (parmse, e, f,
+ fsym ? fsym->attr.intent : INTENT_INOUT);
+
+ /* The actual argument is a reference to the procedure containing the
+ call, when it does not have an explicit result. */
+ else if (psym && psym->attr.flavor == FL_PROCEDURE
+ && (psym->backend_decl == current_function_decl
+ ||
+ psym->backend_decl == parent))
+ {
+ int b = (parent == psym->backend_decl) ? 1 : 0;
+ parmse->expr = gfc_get_fake_result_decl (psym, b);
+
+ /* Pass a descriptor if required. */
+ if (f == 0 && GFC_ARRAY_TYPE_P (TREE_TYPE (parmse->expr)))
+ {
+ tmp = gfc_conv_array_data (parmse->expr);
+ gfc_conv_expr_descriptor (parmse, e, argss);
+ parmse->expr = build_fold_addr_expr (parmse->expr);
+ }
+ else if (f == 1 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE
(parmse->expr))))
+ parmse->expr = gfc_conv_array_data (build_fold_indirect_ref
(parmse->expr));
+
+ if (psym->ts.type == BT_CHARACTER)
+ parmse->string_length = psym->ts.cl->backend_decl;
+ }
+
+ /* The actual argument is an ordinary, honest-to-goodness array. */
+ else
+ gfc_conv_array_parameter (parmse, e, argss, f);
+
+ /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated
+ on entry, it must be deallocated. */
+ if (fsym && fsym->attr.allocatable
+ && fsym->attr.intent == INTENT_OUT)
+ {
+ tmp = build_fold_indirect_ref (parmse->expr);
+ tmp = gfc_trans_dealloc_allocated (tmp);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+ }
+
+
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
Return nonzero, if the call has alternate specifiers. */
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 2132,2172 ****
}
}
else
! {
! /* If the procedure requires an explicit interface, the actual
! argument is passed according to the corresponding formal
! argument. If the corresponding formal argument is a
POINTER,
! ALLOCATABLE or assumed shape, we do not use g77's calling
! convention, and pass the address of the array descriptor
! instead. Otherwise we use g77's calling convention. */
! int f;
! f = (fsym != NULL)
! && !(fsym->attr.pointer || fsym->attr.allocatable)
! && fsym->as->type != AS_ASSUMED_SHAPE;
! f = f || !sym->attr.always_explicit;
!
! if (e->expr_type == EXPR_VARIABLE
! && is_aliased_array (e))
! /* The actual argument is a component reference to an
! array of derived types. In this case, the argument
! is converted to a temporary, which is passed and then
! written back after the procedure call. */
! gfc_conv_aliased_arg (&parmse, e, f,
! fsym ? fsym->attr.intent : INTENT_INOUT);
! else
! gfc_conv_array_parameter (&parmse, e, argss, f);
!
! /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
! allocated on entry, it must be deallocated. */
! if (fsym && fsym->attr.allocatable
! && fsym->attr.intent == INTENT_OUT)
! {
! tmp = build_fold_indirect_ref (parmse.expr);
! tmp = gfc_trans_dealloc_allocated (tmp);
! gfc_add_expr_to_block (&se->pre, tmp);
! }
!
! }
}
if (fsym)
--- 2208,2214 ----
}
}
else
! gfc_conv_array_arg (se, &parmse, argss, e, sym, fsym);
}
if (fsym)
Paul
--
pault at gcc dot gnu dot org changed:
What |Removed |Added
----------------------------------------------------------------------------
AssignedTo|unassigned at gcc dot gnu |pault at gcc dot gnu dot org
|dot org |
Status|NEW |ASSIGNED
Last reconfirmed|2007-04-25 07:38:17 |2007-05-04 07:29:09
date| |
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=31692
