PR fortran/42769

[pf3gnuchains/gcc-fork.git] / gcc / fortran / resolve.c

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4dcf9b1..18e94a1 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -363,10 +363,12 @@ resolve_formal_arglist (gfc_symbol *proc)
            }
          else if (!sym->attr.pointer)
            {
-             if (proc->attr.function && sym->attr.intent != INTENT_IN)
+             if (proc->attr.function && sym->attr.intent != INTENT_IN
+                 && !sym->value)
                proc->attr.implicit_pure = 0;
 
-             if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
+             if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN
+                 && !sym->value)
                proc->attr.implicit_pure = 0;
            }
        }
@@ -1496,7 +1498,7 @@ resolve_intrinsic (gfc_symbol *sym, locus *loc)
 
   if (sym->intmod_sym_id)
     isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
-  else
+  else if (!sym->attr.subroutine)
     isym = gfc_find_function (sym->name);
 
   if (isym)
@@ -3634,7 +3636,7 @@ resolve_call (gfc_code *c)
   if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
     {
       gfc_symtree *st;
-      gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
+      gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
       sym = st ? st->n.sym : NULL;
       if (sym && csym != sym
              && sym->ns == gfc_current_ns
@@ -5624,12 +5626,11 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
   e->value.compcall.actual = NULL;
 
   /* If we find a deferred typebound procedure, check for derived types
-     that an over-riding typebound procedure has not been missed.  */
-  if (e->value.compcall.tbp->deferred
-       && e->value.compcall.name
-       && !e->value.compcall.tbp->non_overridable
-       && e->value.compcall.base_object
-       && e->value.compcall.base_object->ts.type == BT_DERIVED)
+     that an overriding typebound procedure has not been missed.  */
+  if (e->value.compcall.name
+      && !e->value.compcall.tbp->non_overridable
+      && e->value.compcall.base_object
+      && e->value.compcall.base_object->ts.type == BT_DERIVED)
     {
       gfc_symtree *st;
       gfc_symbol *derived;
@@ -7279,8 +7280,8 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
          }
     }
 
-  /* Check that an allocate-object appears only once in the statement.  
-     FIXME: Checking derived types is disabled.  */
+  /* Check that an allocate-object appears only once in the statement.  */
+
   for (p = code->ext.alloc.list; p; p = p->next)
     {
       pe = p->expr;
@@ -7328,11 +7329,18 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
 
                      if (pr->next && qr->next)
                        {
+                         int i;
                          gfc_array_ref *par = &(pr->u.ar);
                          gfc_array_ref *qar = &(qr->u.ar);
-                         if (gfc_dep_compare_expr (par->start[0],
-                                                   qar->start[0]) != 0)
-                             break;
+
+                         for (i=0; i<par->dimen; i++)
+                           {
+                             if ((par->start[i] != NULL
+                                  || qar->start[i] != NULL)
+                                 && gfc_dep_compare_expr (par->start[i],
+                                                          qar->start[i]) != 0)
+                               goto break_label;
+                           }
                        }
                    }
                  else
@@ -7344,6 +7352,8 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
                  pr = pr->next;
                  qr = qr->next;
                }
+           break_label:
+             ;
            }
        }
     }
@@ -10028,7 +10038,8 @@ build_default_init_expr (gfc_symbol *sym)
       || sym->attr.data
       || sym->module
       || sym->attr.cray_pointee
-      || sym->attr.cray_pointer)
+      || sym->attr.cray_pointer
+      || sym->assoc)
     return NULL;
 
   /* Now we'll try to build an initializer expression.  */
@@ -11991,6 +12002,8 @@ resolve_fl_derived (gfc_symbol *sym)
   if (!sym->attr.is_class)
     gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
   if (gen_dt && gen_dt->generic && gen_dt->generic->next
+      && (!gen_dt->generic->sym->attr.use_assoc
+         || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module)
       && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of "
                         "function '%s' at %L being the same name as derived "
                         "type at %L", sym->name,
@@ -13189,10 +13202,9 @@ gfc_impure_variable (gfc_symbol *sym)
     }
 
   proc = sym->ns->proc_name;
-  if (sym->attr.dummy && gfc_pure (proc)
-       && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
-               ||
-            proc->attr.function))
+  if (sym->attr.dummy
+      && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
+         || proc->attr.function))
     return 1;
 
   /* TODO: Sort out what can be storage associated, if anything, and include