decl.c: Add decl_type_param_list...

[gcc.git] / gcc / fortran / trans-expr.c

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 01b7dd27dced2dafe11d236c67c380abdf97a3d6..b3104586ca6841122c1e6b637abaafe6ea9a9ebd 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1839,11 +1839,10 @@ gfc_get_tree_for_caf_expr (gfc_expr *expr)
       }
 
   /* Make sure the backend_decl is present before accessing it.  */
-  if (expr->symtree->n.sym->backend_decl == NULL_TREE)
-    expr->symtree->n.sym->backend_decl
-       = gfc_get_symbol_decl (expr->symtree->n.sym);
-  caf_decl = expr->symtree->n.sym->backend_decl;
-  gcc_assert (caf_decl);
+  caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
+      ? gfc_get_symbol_decl (expr->symtree->n.sym)
+      : expr->symtree->n.sym->backend_decl;
+
   if (expr->symtree->n.sym->ts.type == BT_CLASS)
     {
       if (expr->ref && expr->ref->type == REF_ARRAY)
@@ -2278,7 +2277,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
        msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
                         "is less than one", name);
       else
-       msg = xasprintf ("Substring out of bounds: lower bound (%%ld)"
+       msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
                         "is less than one");
       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
                               fold_convert (long_integer_type_node,
@@ -2545,8 +2544,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
       if (se_expr)
        se->expr = se_expr;
 
-      /* Procedure actual arguments.  */
-      else if (sym->attr.flavor == FL_PROCEDURE
+      /* Procedure actual arguments.  Look out for temporary variables
+        with the same attributes as function values.  */
+      else if (!sym->attr.temporary
+              && sym->attr.flavor == FL_PROCEDURE
               && se->expr != current_function_decl)
        {
          if (!sym->attr.dummy && !sym->attr.proc_pointer)
@@ -5453,6 +5454,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
              if (fsym && fsym->attr.allocatable
                  && fsym->attr.intent == INTENT_OUT)
                {
+                 if (fsym->ts.type == BT_DERIVED
+                     && fsym->ts.u.derived->attr.alloc_comp)
+                 {
+                   // deallocate the components first
+                   tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
+                                                    parmse.expr, e->rank);
+                   if (tmp != NULL_TREE)
+                     gfc_add_expr_to_block (&se->pre, tmp);
+                 }
+
                  tmp = build_fold_indirect_ref_loc (input_location,
                                                     parmse.expr);
                  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
@@ -6121,7 +6132,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
      after use. This necessitates the creation of a temporary to
      hold the result to prevent duplicate calls.  */
   if (!byref && sym->ts.type != BT_CHARACTER
-      && sym->attr.allocatable && !sym->attr.dimension)
+      && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
+         || (comp && comp->attr.allocatable && !comp->attr.dimension)))
     {
       tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
       gfc_add_modify (&se->pre, tmp, se->expr);
@@ -6227,13 +6239,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       gfc_add_block_to_block (&se->pre, &post);
 
       /* Transformational functions of derived types with allocatable
-         components must have the result allocatable components copied.  */
+        components must have the result allocatable components copied when the
+        argument is actually given.  */
       arg = expr->value.function.actual;
       if (result && arg && expr->rank
-           && expr->value.function.isym
-           && expr->value.function.isym->transformational
-           && arg->expr->ts.type == BT_DERIVED
-           && arg->expr->ts.u.derived->attr.alloc_comp)
+         && expr->value.function.isym
+         && expr->value.function.isym->transformational
+         && arg->expr
+         && arg->expr->ts.type == BT_DERIVED
+         && arg->expr->ts.u.derived->attr.alloc_comp)
        {
          tree tmp2;
          /* Copy the allocatable components.  We have to use a
@@ -7272,7 +7286,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
     {
       if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
        gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
-      else if (cm->attr.allocatable)
+      else if (cm->attr.allocatable || cm->attr.pdt_array)
        {
          tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
          gfc_add_expr_to_block (&block, tmp);
@@ -7515,7 +7529,6 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
          && (!c->expr || c->expr->expr_type == EXPR_NULL))
        {
          tree token, desc, size;
-         symbol_attribute attr;
          bool is_array = cm->ts.type == BT_CLASS
              ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
 
@@ -7548,7 +7561,10 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
            }
          else
            {
-             desc = gfc_conv_scalar_to_descriptor (&se, field, attr);
+             desc = gfc_conv_scalar_to_descriptor (&se, field,
+                                                   cm->ts.type == BT_CLASS
+                                                   ? CLASS_DATA (cm)->attr
+                                                   : cm->attr);
              size = TYPE_SIZE_UNIT (TREE_TYPE (field));
            }
          gfc_add_block_to_block (&block, &se.pre);
@@ -9958,13 +9974,16 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
          tree cond;
          const char* msg;
 
+         tmp = INDIRECT_REF_P (lse.expr)
+             ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
+
          /* We should only get array references here.  */
-         gcc_assert (TREE_CODE (lse.expr) == POINTER_PLUS_EXPR
-                     || TREE_CODE (lse.expr) == ARRAY_REF);
+         gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
+                     || TREE_CODE (tmp) == ARRAY_REF);
 
          /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
             or the array itself(ARRAY_REF).  */
-         tmp = TREE_OPERAND (lse.expr, 0);
+         tmp = TREE_OPERAND (tmp, 0);
 
          /* Provide the address of the array.  */
          if (TREE_CODE (lse.expr) == ARRAY_REF)