[Bug fortran/31692] Wrong code when passing function name as result to procedures

["pault at gcc dot gnu dot org" <gcc-bugzilla at gcc dot gnu dot org>]

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