fortran/

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

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 2d85a56..0b9dc73 100644 (file)
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -791,7 +791,7 @@ not_yes:
 /*********************** Statement level matching **********************/
 
 /* Matches the start of a program unit, which is the program keyword
-   followed by an optional symbol.  */
+   followed by an obligatory symbol.  */
 
 match
 gfc_match_program (void)
@@ -799,10 +799,6 @@ gfc_match_program (void)
   gfc_symbol *sym;
   match m;
 
-  m = gfc_match_eos ();
-  if (m == MATCH_YES)
-    return m;
-
   m = gfc_match ("% %s%t", &sym);
 
   if (m == MATCH_NO)
@@ -1897,6 +1893,13 @@ gfc_match_return (void)
 {
   gfc_expr *e;
   match m;
+  gfc_compile_state s;
+
+  gfc_enclosing_unit (&s);
+  if (s == COMP_PROGRAM
+      && gfc_notify_std (GFC_STD_GNU, "RETURN statement in a main "
+                        "program at %C is an extension.") == FAILURE)
+      return MATCH_ERROR;
 
   e = NULL;
   if (gfc_match_eos () == MATCH_YES)
@@ -2049,22 +2052,38 @@ cleanup:
 
 
 /* Given a name, return a pointer to the common head structure,
-   creating it if it does not exist.
+   creating it if it does not exist. If FROM_MODULE is non-zero, we
+   mangle the name so that it doesn't interfere with commons defined 
+   in the using namespace.
    TODO: Add to global symbol tree.  */
 
 gfc_common_head *
-gfc_get_common (char *name)
+gfc_get_common (const char *name, int from_module)
 {
   gfc_symtree *st;
+  static int serial = 0;
+  char mangled_name[GFC_MAX_SYMBOL_LEN+1];
 
-  st = gfc_find_symtree (gfc_current_ns->common_root, name);
-  if (st == NULL)
-    st = gfc_new_symtree (&gfc_current_ns->common_root, name);
+  if (from_module)
+    {
+      /* A use associated common block is only needed to correctly layout
+        the variables it contains.  */
+      snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
+      st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
+    }
+  else
+    {
+      st = gfc_find_symtree (gfc_current_ns->common_root, name);
+
+      if (st == NULL)
+       st = gfc_new_symtree (&gfc_current_ns->common_root, name);
+    }
 
   if (st->n.common == NULL)
     {
       st->n.common = gfc_get_common_head ();
       st->n.common->where = gfc_current_locus;
+      strcpy (st->n.common->name, name);
     }
 
   return st->n.common;
@@ -2140,15 +2159,8 @@ gfc_match_common (void)
        }
       else
        {
-         t = gfc_get_common (name);
+         t = gfc_get_common (name, 0);
          head = &t->head;
-
-         if (t->use_assoc)
-           {
-             gfc_error ("COMMON block '%s' at %C has already "
-                        "been USE-associated", name);
-             goto cleanup;
-           }
        }
 
       if (*head == NULL)
@@ -2286,7 +2298,7 @@ gfc_match_block_data (void)
       return MATCH_YES;
     }
 
-  m = gfc_match (" %n%t", name);
+  m = gfc_match ("% %n%t", name);
   if (m != MATCH_YES)
     return MATCH_ERROR;