------- 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