PR middle-end/40500

[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-decl.c

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 783c8f8..4e72a23 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -578,6 +578,11 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
   if (sym->attr.threadprivate
       && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
     DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
+
+  if (!sym->attr.target
+      && !sym->attr.pointer
+      && !sym->attr.proc_pointer)
+    DECL_RESTRICTED_P (decl) = 1;
 }
 
 
@@ -796,7 +801,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
 
   /* Do we know the element size?  */
   known_size = sym->ts.type != BT_CHARACTER
-         || INTEGER_CST_P (sym->ts.cl->backend_decl);
+         || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
   
   if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
     {
@@ -840,7 +845,8 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
        }
 
       type = gfc_typenode_for_spec (&sym->ts);
-      type = gfc_get_nodesc_array_type (type, sym->as, packed);
+      type = gfc_get_nodesc_array_type (type, sym->as, packed,
+                                       !sym->attr.target);
     }
   else
     {
@@ -928,10 +934,10 @@ gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
 static tree
 gfc_create_string_length (gfc_symbol * sym)
 {
-  gcc_assert (sym->ts.cl);
-  gfc_conv_const_charlen (sym->ts.cl);
+  gcc_assert (sym->ts.u.cl);
+  gfc_conv_const_charlen (sym->ts.u.cl);
 
-  if (sym->ts.cl->backend_decl == NULL_TREE)
+  if (sym->ts.u.cl->backend_decl == NULL_TREE)
     {
       tree length;
       char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
@@ -947,11 +953,11 @@ gfc_create_string_length (gfc_symbol * sym)
       if (sym->ns->proc_name->tlink != NULL)
        gfc_defer_symbol_init (sym);
 
-      sym->ts.cl->backend_decl = length;
+      sym->ts.u.cl->backend_decl = length;
     }
 
-  gcc_assert (sym->ts.cl->backend_decl != NULL_TREE);
-  return sym->ts.cl->backend_decl;
+  gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
+  return sym->ts.u.cl->backend_decl;
 }
 
 /* If a variable is assigned a label, we add another two auxiliary
@@ -1050,10 +1056,10 @@ gfc_get_symbol_decl (gfc_symbol * sym)
       /* Create a character length variable.  */
       if (sym->ts.type == BT_CHARACTER)
        {
-         if (sym->ts.cl->backend_decl == NULL_TREE)
+         if (sym->ts.u.cl->backend_decl == NULL_TREE)
            length = gfc_create_string_length (sym);
          else
-           length = sym->ts.cl->backend_decl;
+           length = sym->ts.u.cl->backend_decl;
          if (TREE_CODE (length) == VAR_DECL
              && DECL_CONTEXT (length) == NULL_TREE)
            {
@@ -1098,6 +1104,32 @@ gfc_get_symbol_decl (gfc_symbol * sym)
   if (sym->backend_decl)
     return sym->backend_decl;
 
+  /* If use associated and whole file compilation, use the module
+     declaration.  This is only needed for intrinsic types because
+     they are substituted for one another during optimization.  */
+  if (gfc_option.flag_whole_file
+       && sym->attr.flavor == FL_VARIABLE
+       && sym->ts.type != BT_DERIVED
+       && sym->attr.use_assoc
+       && sym->module)
+    {
+      gfc_gsymbol *gsym;
+
+      gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
+      if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
+       {
+         gfc_symbol *s;
+         s = NULL;
+         gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+         if (s && s->backend_decl)
+           {
+             if (sym->ts.type == BT_CHARACTER)
+               sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
+             return s->backend_decl;
+           }
+       }
+    }
+
   /* Catch function declarations.  Only used for actual parameters and
      procedure pointers.  */
   if (sym->attr.flavor == FL_PROCEDURE)
@@ -1145,7 +1177,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
        GFC_DECL_PACKED_ARRAY (decl) = 1;
     }
 
-  if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
+  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
     gfc_defer_symbol_init (sym);
   /* This applies a derived type default initializer.  */
   else if (sym->ts.type == BT_DERIVED
@@ -1341,6 +1373,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
   gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->name);
 
   if (gfc_option.flag_whole_file
+       && !sym->attr.use_assoc
        && !sym->backend_decl
        && gsym && gsym->ns
        && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
@@ -1371,6 +1404,26 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
        return sym->backend_decl;
     }
 
+  /* See if this is a module procedure from the same file.  If so,
+     return the backend_decl.  */
+  if (sym->module)
+    gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
+
+  if (gfc_option.flag_whole_file
+       && gsym && gsym->ns
+       && gsym->type == GSYM_MODULE)
+    {
+      gfc_symbol *s;
+
+      s = NULL;
+      gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+      if (s && s->backend_decl)
+       {
+         sym->backend_decl = s->backend_decl;
+         return sym->backend_decl;
+       }
+    }
+
   if (sym->attr.intrinsic)
     {
       /* Call the resolution function to get the actual name.  This is
@@ -1649,9 +1702,9 @@ create_function_arglist (gfc_symbol * sym)
                               PARM_DECL,
                               get_identifier (".__result"),
                               len_type);
-         if (!sym->ts.cl->length)
+         if (!sym->ts.u.cl->length)
            {
-             sym->ts.cl->backend_decl = length;
+             sym->ts.u.cl->backend_decl = length;
              TREE_USED (length) = 1;
            }
          gcc_assert (TREE_CODE (length) == PARM_DECL);
@@ -1660,13 +1713,13 @@ create_function_arglist (gfc_symbol * sym)
          TREE_READONLY (length) = 1;
          DECL_ARTIFICIAL (length) = 1;
          gfc_finish_decl (length);
-         if (sym->ts.cl->backend_decl == NULL
-             || sym->ts.cl->backend_decl == length)
+         if (sym->ts.u.cl->backend_decl == NULL
+             || sym->ts.u.cl->backend_decl == length)
            {
              gfc_symbol *arg;
              tree backend_decl;
 
-             if (sym->ts.cl->backend_decl == NULL)
+             if (sym->ts.u.cl->backend_decl == NULL)
                {
                  tree len = build_decl (input_location,
                                         VAR_DECL,
@@ -1674,7 +1727,7 @@ create_function_arglist (gfc_symbol * sym)
                                         gfc_charlen_type_node);
                  DECL_ARTIFICIAL (len) = 1;
                  TREE_USED (len) = 1;
-                 sym->ts.cl->backend_decl = len;
+                 sym->ts.u.cl->backend_decl = len;
                }
 
              /* Make sure PARM_DECL type doesn't point to incomplete type.  */
@@ -1744,38 +1797,29 @@ create_function_arglist (gfc_symbol * sym)
          gfc_finish_decl (length);
 
          /* Remember the passed value.  */
-          if (f->sym->ts.cl->passed_length != NULL)
+          if (f->sym->ts.u.cl->passed_length != NULL)
             {
              /* This can happen if the same type is used for multiple
                 arguments. We need to copy cl as otherwise
                 cl->passed_length gets overwritten.  */
-             gfc_charlen *cl, *cl2;
-             cl = f->sym->ts.cl;
-             f->sym->ts.cl = gfc_get_charlen();
-             f->sym->ts.cl->length = cl->length;
-             f->sym->ts.cl->backend_decl = cl->backend_decl;
-             f->sym->ts.cl->length_from_typespec = cl->length_from_typespec;
-             f->sym->ts.cl->resolved = cl->resolved;
-             cl2 = f->sym->ts.cl->next;
-             f->sym->ts.cl->next = cl;
-              cl->next = cl2;
+             f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
             }
-         f->sym->ts.cl->passed_length = length;
+         f->sym->ts.u.cl->passed_length = length;
 
          /* Use the passed value for assumed length variables.  */
-         if (!f->sym->ts.cl->length)
+         if (!f->sym->ts.u.cl->length)
            {
              TREE_USED (length) = 1;
-             gcc_assert (!f->sym->ts.cl->backend_decl);
-             f->sym->ts.cl->backend_decl = length;
+             gcc_assert (!f->sym->ts.u.cl->backend_decl);
+             f->sym->ts.u.cl->backend_decl = length;
            }
 
          hidden_typelist = TREE_CHAIN (hidden_typelist);
 
-         if (f->sym->ts.cl->backend_decl == NULL
-             || f->sym->ts.cl->backend_decl == length)
+         if (f->sym->ts.u.cl->backend_decl == NULL
+             || f->sym->ts.u.cl->backend_decl == length)
            {
-             if (f->sym->ts.cl->backend_decl == NULL)
+             if (f->sym->ts.u.cl->backend_decl == NULL)
                gfc_create_string_length (f->sym);
 
              /* Make sure PARM_DECL type doesn't point to incomplete type.  */
@@ -1946,7 +1990,7 @@ build_entry_thunks (gfc_namespace * ns)
                                args);
              if (formal->sym->ts.type == BT_CHARACTER)
                {
-                 tmp = thunk_formal->sym->ts.cl->backend_decl;
+                 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
                  string_args = tree_cons (NULL_TREE, tmp, string_args);
                }
            }
@@ -2043,15 +2087,15 @@ build_entry_thunks (gfc_namespace * ns)
          {
            formal->sym->backend_decl = NULL_TREE;
            if (formal->sym->ts.type == BT_CHARACTER)
-             formal->sym->ts.cl->backend_decl = NULL_TREE;
+             formal->sym->ts.u.cl->backend_decl = NULL_TREE;
          }
 
       if (thunk_sym->attr.function)
        {
          if (thunk_sym->ts.type == BT_CHARACTER)
-           thunk_sym->ts.cl->backend_decl = NULL_TREE;
+           thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
          if (thunk_sym->result->ts.type == BT_CHARACTER)
-           thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
+           thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
        }
     }
 
@@ -2160,10 +2204,10 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
 
   if (sym->ts.type == BT_CHARACTER)
     {
-      if (sym->ts.cl->backend_decl == NULL_TREE)
+      if (sym->ts.u.cl->backend_decl == NULL_TREE)
        length = gfc_create_string_length (sym);
       else
-       length = sym->ts.cl->backend_decl;
+       length = sym->ts.u.cl->backend_decl;
       if (TREE_CODE (length) == VAR_DECL
          && DECL_CONTEXT (length) == NULL_TREE)
        gfc_add_decl_to_function (length);
@@ -2769,12 +2813,12 @@ gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
   tree tmp;
 
   gcc_assert (sym->backend_decl);
-  gcc_assert (sym->ts.cl && sym->ts.cl->length);
+  gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
 
   gfc_start_block (&body);
 
   /* Evaluate the string length expression.  */
-  gfc_conv_string_length (sym->ts.cl, NULL, &body);
+  gfc_conv_string_length (sym->ts.u.cl, NULL, &body);
 
   gfc_trans_vla_type_sizes (sym, &body);
 
@@ -2962,9 +3006,9 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body)
        && !f->sym->attr.pointer
        && f->sym->ts.type == BT_DERIVED)
       {
-       if (f->sym->ts.derived->attr.alloc_comp)
+       if (f->sym->ts.u.derived->attr.alloc_comp)
          {
-           tmp = gfc_deallocate_alloc_comp (f->sym->ts.derived,
+           tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
                                             f->sym->backend_decl,
                                             f->sym->as ? f->sym->as->rank : 0);
 
@@ -2975,7 +3019,7 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body)
            gfc_add_expr_to_block (&fnblock, tmp);
          }
 
-       if (!f->sym->ts.derived->attr.alloc_comp
+       if (!f->sym->ts.u.derived->attr.alloc_comp
              && f->sym->value)
          body = gfc_init_default_dt (f->sym, body);
       }
@@ -3026,14 +3070,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 
          /* An automatic character length, pointer array result.  */
          if (proc_sym->ts.type == BT_CHARACTER
-               && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
-           fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
+               && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
+           fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
                                                fnbody);
        }
       else if (proc_sym->ts.type == BT_CHARACTER)
        {
-         if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
-           fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
+         if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
+           fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
                                                fnbody);
        }
       else
@@ -3049,7 +3093,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
     {
       bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
-                                  && sym->ts.derived->attr.alloc_comp;
+                                  && sym->ts.u.derived->attr.alloc_comp;
       if (sym->attr.dimension)
        {
          switch (sym->as->type)
@@ -3123,7 +3167,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
          gfc_get_backend_locus (&loc);
          gfc_set_backend_locus (&sym->declared_at);
          if (sym->attr.dummy || sym->attr.result)
-           fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
+           fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);
          else
            fnbody = gfc_trans_auto_character_variable (sym, fnbody);
          gfc_set_backend_locus (&loc);
@@ -3150,8 +3194,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
     {
       if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
        {
-         gcc_assert (f->sym->ts.cl->backend_decl != NULL);
-         if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
+         gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
+         if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
            gfc_trans_vla_type_sizes (f->sym, &body);
        }
     }
@@ -3159,8 +3203,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
   if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
       && current_fake_result_decl != NULL)
     {
-      gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
-      if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
+      gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
+      if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
        gfc_trans_vla_type_sizes (proc_sym, &body);
     }
 
@@ -3334,7 +3378,7 @@ gfc_create_module_variable (gfc_symbol * sym)
     {
       tree length;
 
-      length = sym->ts.cl->backend_decl;
+      length = sym->ts.u.cl->backend_decl;
       if (!INTEGER_CST_P (length))
         {
           pushdecl (length);
@@ -3388,7 +3432,13 @@ gfc_trans_use_stmts (gfc_namespace * ns)
              st = gfc_find_symtree (ns->sym_root,
                                     rent->local_name[0]
                                     ? rent->local_name : rent->use_name);
-             gcc_assert (st && st->n.sym->attr.use_assoc);
+             gcc_assert (st);
+
+             /* Sometimes, generic interfaces wind up being over-ruled by a
+                local symbol (see PR41062).  */
+             if (!st->n.sym->attr.use_assoc)
+               continue;
+
              if (st->n.sym->backend_decl
                  && DECL_P (st->n.sym->backend_decl)
                  && st->n.sym->module
@@ -3464,7 +3514,7 @@ check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
     case BT_DERIVED:
       if (expr->expr_type != EXPR_STRUCTURE)
        return false;
-      cm = expr->ts.derived->components;
+      cm = expr->ts.u.derived->components;
       for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
        {
          if (!c->expr || cm->attr.allocatable)
@@ -3510,12 +3560,12 @@ gfc_emit_parameter_debug_info (gfc_symbol *sym)
 
   if (sym->ts.type == BT_CHARACTER)
     {
-      gfc_conv_const_charlen (sym->ts.cl);
-      if (sym->ts.cl->backend_decl == NULL
-         || TREE_CODE (sym->ts.cl->backend_decl) != INTEGER_CST)
+      gfc_conv_const_charlen (sym->ts.u.cl);
+      if (sym->ts.u.cl->backend_decl == NULL
+         || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
        return;
     }
-  else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
+  else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
     return;
 
   if (sym->as)
@@ -3643,10 +3693,10 @@ generate_dependency_declarations (gfc_symbol *sym)
   int i;
 
   if (sym->ts.type == BT_CHARACTER
-      && sym->ts.cl
-      && sym->ts.cl->length
-      && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
-    generate_expr_decls (sym, sym->ts.cl->length);
+      && sym->ts.u.cl
+      && sym->ts.u.cl->length
+      && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+    generate_expr_decls (sym, sym->ts.u.cl->length);
 
   if (sym->as && sym->as->rank)
     {
@@ -3697,8 +3747,8 @@ generate_local_decl (gfc_symbol * sym)
         warning if requested.  */
       if (sym->attr.dummy && !sym->attr.referenced
            && sym->ts.type == BT_CHARACTER
-           && sym->ts.cl->backend_decl != NULL
-           && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
+           && sym->ts.u.cl->backend_decl != NULL
+           && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
        {
          sym->attr.referenced = 1;
          gfc_get_symbol_decl (sym);
@@ -3709,7 +3759,7 @@ generate_local_decl (gfc_symbol * sym)
         generate the code for nullification and automatic lengths.  */
       if (!sym->attr.referenced
            && sym->ts.type == BT_DERIVED
-           && sym->ts.derived->attr.alloc_comp
+           && sym->ts.u.derived->attr.alloc_comp
            && !sym->attr.pointer
            && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
                  ||
@@ -3840,7 +3890,7 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
        const char *message;
 
        fsym = formal->sym;
-       cl = fsym->ts.cl;
+       cl = fsym->ts.u.cl;
 
        gcc_assert (cl);
        gcc_assert (cl->passed_length != NULL_TREE);
@@ -4177,10 +4227,10 @@ gfc_generate_function_code (gfc_namespace * ns)
       gfc_entry_list *el;
       tree backend_decl;
 
-      gfc_conv_const_charlen (ns->proc_name->ts.cl);
-      backend_decl = ns->proc_name->result->ts.cl->backend_decl;
+      gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
+      backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
       for (el = ns->entries; el; el = el->next)
-       el->sym->result->ts.cl->backend_decl = backend_decl;
+       el->sym->result->ts.u.cl->backend_decl = backend_decl;
     }
 
   /* Translate COMMON blocks.  */
@@ -4281,11 +4331,11 @@ gfc_generate_function_code (gfc_namespace * ns)
 
       if (result != NULL_TREE && sym->attr.function
            && sym->ts.type == BT_DERIVED
-           && sym->ts.derived->attr.alloc_comp
+           && sym->ts.u.derived->attr.alloc_comp
            && !sym->attr.pointer)
        {
          rank = sym->as ? sym->as->rank : 0;
-         tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
+         tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
          gfc_add_expr_to_block (&block, tmp2);
        }