PR fortran/15976

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

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f6fb2b0..0f17585 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4238,8 +4238,10 @@ resolve_symbol (gfc_symbol * sym)
 
       if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
        {
+         /* The specific case of an external procedure should emit an error
+            in the case that there is no implicit type.  */
          if (!mp_flag)
-           gfc_set_default_type (sym, 0, NULL);
+           gfc_set_default_type (sym, sym->attr.external, NULL);
          else
            {
               /* Result may be in another namespace.  */
@@ -4280,6 +4282,22 @@ resolve_symbol (gfc_symbol * sym)
          return;
     }
 
+  /* A module array's shape needs to be constant.  */
+
+  if (sym->ns->proc_name
+      && sym->attr.flavor == FL_VARIABLE
+      && sym->ns->proc_name->attr.flavor == FL_MODULE
+      && !sym->attr.use_assoc
+      && !sym->attr.allocatable
+      && !sym->attr.pointer
+      && sym->as != NULL
+      && !gfc_is_compile_time_shape (sym->as))
+    {
+      gfc_error ("Module array '%s' at %L cannot be automatic "
+         "or assumed shape", sym->name, &sym->declared_at);
+      return;
+    }
+
   /* Make sure that character string variables with assumed length are
      dummy arguments.  */
 
@@ -4356,9 +4374,11 @@ resolve_symbol (gfc_symbol * sym)
       return;
     }
 
-  /* Ensure that derived type components of a public derived type
-     are not of a private type.  */
+  /* If a component of a derived type is of a type declared to be private,
+     either the derived type definition must contain the PRIVATE statement,
+     or the derived type must be private.  (4.4.1 just after R427) */
   if (sym->attr.flavor == FL_DERIVED
+       && sym->component_access != ACCESS_PRIVATE
        && gfc_check_access(sym->attr.access, sym->ns->default_access))
     {
       for (c = sym->components; c; c = c->next)
@@ -4430,18 +4450,18 @@ resolve_symbol (gfc_symbol * sym)
          if (sym->attr.allocatable)
            {
              if (sym->attr.dimension)
-               gfc_error ("Allocatable array at %L must have a deferred shape",
-                          &sym->declared_at);
+               gfc_error ("Allocatable array '%s' at %L must have "
+                          "a deferred shape", sym->name, &sym->declared_at);
              else
-               gfc_error ("Object at %L may not be ALLOCATABLE",
-                          &sym->declared_at);
+               gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
+                          sym->name, &sym->declared_at);
              return;
            }
 
          if (sym->attr.pointer && sym->attr.dimension)
            {
-             gfc_error ("Pointer to array at %L must have a deferred shape",
-                        &sym->declared_at);
+             gfc_error ("Array pointer '%s' at %L must have a deferred shape",
+                        sym->name, &sym->declared_at);
              return;
            }
 
@@ -4451,8 +4471,8 @@ resolve_symbol (gfc_symbol * sym)
          if (!mp_flag && !sym->attr.allocatable
              && !sym->attr.pointer && !sym->attr.dummy)
            {
-             gfc_error ("Array at %L cannot have a deferred shape",
-                        &sym->declared_at);
+             gfc_error ("Array '%s' at %L cannot have a deferred shape",
+                        sym->name, &sym->declared_at);
              return;
            }
        }
@@ -4461,7 +4481,7 @@ resolve_symbol (gfc_symbol * sym)
   switch (sym->attr.flavor)
     {
     case FL_VARIABLE:
-      /* Can the sybol have an initializer?  */
+      /* Can the symbol have an initializer?  */
       flag = 0;
       if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
          || sym->attr.intrinsic || sym->attr.result)
@@ -4536,8 +4556,8 @@ resolve_symbol (gfc_symbol * sym)
       /* An external symbol falls through to here if it is not referenced.  */
       if (sym->attr.external && sym->value)
        {
-         gfc_error ("External object at %L may not have an initializer",
-                    &sym->declared_at);
+         gfc_error ("External object '%s' at %L may not have an initializer",
+                    sym->name, &sym->declared_at);
          return;
        }