PR fortran/23677

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

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index efe1211..de2de4b 100644 (file)
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -17,8 +17,8 @@ for more details.
 
 You should have received a copy of the GNU General Public License
 along with GCC; see the file COPYING.  If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.  */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.  */
 
 
 #include "config.h"
@@ -106,6 +106,14 @@ gfc_set_implicit_none (void)
 {
   int i;
 
+  if (gfc_current_ns->seen_implicit_none)
+    {
+      gfc_error ("Duplicate IMPLICIT NONE statement at %C");
+      return;
+    }
+
+  gfc_current_ns->seen_implicit_none = 1;
+
   for (i = 0; i < GFC_LETTERS; i++)
     {
       gfc_clear_ts (&gfc_current_ns->default_type[i]);
@@ -160,6 +168,12 @@ gfc_merge_new_implicit (gfc_typespec * ts)
 {
   int i;
 
+  if (gfc_current_ns->seen_implicit_none)
+    {
+      gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
+      return FAILURE;
+    }
+
   for (i = 0; i < GFC_LETTERS; i++)
     {
       if (new_flag[i])
@@ -213,9 +227,12 @@ gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns)
 
   if (ts->type == BT_UNKNOWN)
     {
-      if (error_flag)
-       gfc_error ("Symbol '%s' at %L has no IMPLICIT type", sym->name,
-                  &sym->declared_at);
+      if (error_flag && !sym->attr.untyped)
+       {
+         gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
+                    sym->name, &sym->declared_at);
+         sym->attr.untyped = 1; /* Ensure we only give an error once.  */
+       }
 
       return FAILURE;
     }
@@ -366,6 +383,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
        {
        case PROC_ST_FUNCTION:
          conf2 (in_common);
+         conf2 (dummy);
          break;
 
        case PROC_MODULE:
@@ -416,6 +434,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
       conf2 (target);
       conf2 (dummy);
       conf2 (in_common);
+      conf2 (save);
       break;
 
     default:
@@ -886,9 +905,8 @@ gfc_add_procedure (symbol_attribute * attr, procedure_type t,
 
   if (attr->proc != PROC_UNKNOWN)
     {
-      gfc_error ("%s procedure at %L is already %s %s procedure",
+      gfc_error ("%s procedure at %L is already declared as %s procedure",
                 gfc_code2string (procedures, t), where,
-                gfc_article (gfc_code2string (procedures, attr->proc)),
                 gfc_code2string (procedures, attr->proc));
 
       return FAILURE;
@@ -1154,7 +1172,7 @@ gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** componen
   else
     tail->next = p;
 
-  strcpy (p->name, name);
+  p->name = gfc_get_string (name);
   p->loc = gfc_current_locus;
 
   *component = p;
@@ -1610,7 +1628,7 @@ gfc_new_symtree (gfc_symtree ** root, const char *name)
   gfc_symtree *st;
 
   st = gfc_getmem (sizeof (gfc_symtree));
-  strcpy (st->name, name);
+  st->name = gfc_get_string (name);
 
   gfc_insert_bbt (root, st, compare_symtree);
   return st;
@@ -1626,7 +1644,7 @@ delete_symtree (gfc_symtree ** root, const char *name)
 
   st0 = gfc_find_symtree (*root, name);
 
-  strcpy (st.name, name);
+  st.name = gfc_get_string (name);
   gfc_delete_bbt (root, &st, compare_symtree);
 
   gfc_free (st0);
@@ -1671,7 +1689,7 @@ gfc_get_uop (const char *name)
   st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
 
   uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
-  strcpy (uop->name, name);
+  uop->name = gfc_get_string (name);
   uop->access = ACCESS_UNKNOWN;
   uop->ns = gfc_current_ns;
 
@@ -1740,7 +1758,7 @@ gfc_new_symbol (const char *name, gfc_namespace * ns)
   if (strlen (name) > GFC_MAX_SYMBOL_LEN)
     gfc_internal_error ("new_symbol(): Symbol name too long");
 
-  strcpy (p->name, name);
+  p->name = gfc_get_string (name);
   return p;
 }
 
@@ -1751,7 +1769,7 @@ static void
 ambiguous_symbol (const char *name, gfc_symtree * st)
 {
 
-  if (st->n.sym->module[0])
+  if (st->n.sym->module)
     gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
               "from module '%s'", name, st->n.sym->name, st->n.sym->module);
   else
@@ -2313,6 +2331,25 @@ gfc_traverse_ns (gfc_namespace * ns, void (*func) (gfc_symbol *))
 }
 
 
+/* Return TRUE if the symbol is an automatic variable.  */
+static bool
+gfc_is_var_automatic (gfc_symbol * sym)
+{
+  /* Pointer and allocatable variables are never automatic.  */
+  if (sym->attr.pointer || sym->attr.allocatable)
+    return false;
+  /* Check for arrays with non-constant size.  */
+  if (sym->attr.dimension && sym->as
+      && !gfc_is_compile_time_shape (sym->as))
+    return true;
+  /* Check for non-constant length character variables.  */
+  if (sym->ts.type == BT_CHARACTER
+      && sym->ts.cl
+      && !gfc_is_constant_expr (sym->ts.cl->length))
+    return true;
+  return false;
+}
+
 /* Given a symbol, mark it as SAVEd if it is allowed.  */
 
 static void
@@ -2326,7 +2363,9 @@ save_symbol (gfc_symbol * sym)
       || sym->attr.dummy
       || sym->attr.flavor != FL_VARIABLE)
     return;
-
+  /* Automatic objects are not saved.  */
+  if (gfc_is_var_automatic (sym))
+    return;
   gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
 }
 
@@ -2359,7 +2398,7 @@ gfc_symbol_state(void) {
 /* Search a tree for the global symbol.  */
 
 gfc_gsymbol *
-gfc_find_gsymbol (gfc_gsymbol *symbol, char *name)
+gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
 {
   gfc_gsymbol *s;
 
@@ -2396,7 +2435,7 @@ gsym_compare (void * _s1, void * _s2)
 /* Get a global symbol, creating it if it doesn't exist.  */
 
 gfc_gsymbol *
-gfc_get_gsymbol (char *name)
+gfc_get_gsymbol (const char *name)
 {
   gfc_gsymbol *s;
 
@@ -2406,7 +2445,7 @@ gfc_get_gsymbol (char *name)
 
   s = gfc_getmem (sizeof (gfc_gsymbol));
   s->type = GSYM_UNKNOWN;
-  strcpy (s->name, name);
+  s->name = gfc_get_string (name);
 
   gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);