2010-12-02 Thomas Koenig <tkoenig@gcc.gnu.org>

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

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index efde1a6..6cd1c46 100644 (file)
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2711,26 +2711,25 @@ gfc_free_alloc_list (gfc_alloc *p)
 static match
 match_derived_type_spec (gfc_typespec *ts)
 {
+  char name[GFC_MAX_SYMBOL_LEN + 1];
   locus old_locus; 
   gfc_symbol *derived;
 
-  old_locus = gfc_current_locus; 
+  old_locus = gfc_current_locus;
 
-  if (gfc_match_symbol (&derived, 1) == MATCH_YES)
+  if (gfc_match ("%n", name) != MATCH_YES)
     {
-      if (derived->attr.flavor == FL_DERIVED)
-       {
-         ts->type = BT_DERIVED;
-         ts->u.derived = derived;
-         return MATCH_YES;
-       }
-      else
-       {
-         /* Enforce F03:C476.  */
-         gfc_error ("'%s' at %L is not an accessible derived type",
-                    derived->name, &gfc_current_locus);
-         return MATCH_ERROR;
-       }
+       gfc_current_locus = old_locus;
+       return MATCH_NO;
+    }
+
+  gfc_find_symbol (name, NULL, 1, &derived);
+
+  if (derived && derived->attr.flavor == FL_DERIVED)
+    {
+      ts->type = BT_DERIVED;
+      ts->u.derived = derived;
+      return MATCH_YES;
     }
 
   gfc_current_locus = old_locus; 
@@ -2752,17 +2751,12 @@ match_type_spec (gfc_typespec *ts)
   locus old_locus;
 
   gfc_clear_ts (ts);
-  gfc_gobble_whitespace();
+  gfc_gobble_whitespace ();
   old_locus = gfc_current_locus;
 
-  m = match_derived_type_spec (ts);
-  if (m == MATCH_YES)
+  if (match_derived_type_spec (ts) == MATCH_YES)
     {
-      old_locus = gfc_current_locus;
-      if (gfc_match (" :: ") != MATCH_YES)
-       return MATCH_ERROR;
-      gfc_current_locus = old_locus;
-      /* Enfore F03:C401.  */
+      /* Enforce F03:C401.  */
       if (ts->u.derived->attr.abstract)
        {
          gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
@@ -2771,10 +2765,6 @@ match_type_spec (gfc_typespec *ts)
        }
       return MATCH_YES;
     }
-  else if (m == MATCH_ERROR && gfc_match (" :: ") == MATCH_YES)
-    return MATCH_ERROR;
-
-  gfc_current_locus = old_locus;
 
   if (gfc_match ("integer") == MATCH_YES)
     {
@@ -2807,7 +2797,13 @@ match_type_spec (gfc_typespec *ts)
   if (gfc_match ("character") == MATCH_YES)
     {
       ts->type = BT_CHARACTER;
-      goto char_selector;
+
+      m = gfc_match_char_spec (ts);
+
+      if (m == MATCH_NO)
+       m = MATCH_YES;
+
+      return m;
     }
 
   if (gfc_match ("logical") == MATCH_YES)
@@ -2836,15 +2832,6 @@ kind_selector:
     m = MATCH_YES;             /* No kind specifier found.  */
 
   return m;
-
-char_selector:
-
-  m = gfc_match_char_spec (ts);
-
-  if (m == MATCH_NO)
-    m = MATCH_YES;             /* No kind specifier found.  */
-
-  return m;
 }
 
 
@@ -2858,12 +2845,12 @@ gfc_match_allocate (void)
   gfc_typespec ts;
   gfc_symbol *sym;
   match m;
-  locus old_locus;
-  bool saw_stat, saw_errmsg, saw_source, saw_mold, b1, b2, b3;
+  locus old_locus, deferred_locus;
+  bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
 
   head = tail = NULL;
   stat = errmsg = source = mold = tmp = NULL;
-  saw_stat = saw_errmsg = saw_source = saw_mold = false;
+  saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
 
   if (gfc_match_char ('(') != MATCH_YES)
     goto syntax;
@@ -2874,7 +2861,17 @@ gfc_match_allocate (void)
   if (m == MATCH_ERROR)
     goto cleanup;
   else if (m == MATCH_NO)
-    ts.type = BT_UNKNOWN;
+    {
+      char name[GFC_MAX_SYMBOL_LEN + 3];
+
+      if (gfc_match ("%n :: ", name) == MATCH_YES)
+       {
+         gfc_error ("Error in type-spec at %L", &old_locus);
+         goto cleanup;
+       }
+
+      ts.type = BT_UNKNOWN;
+    }
   else
     {
       if (gfc_match (" :: ") == MATCH_YES)
@@ -2882,6 +2879,13 @@ gfc_match_allocate (void)
          if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
                              "ALLOCATE at %L", &old_locus) == FAILURE)
            goto cleanup;
+
+         if (ts.deferred)
+           {
+             gfc_error ("Type-spec at %L cannot contain a deferred "
+                        "type parameter", &old_locus);
+             goto cleanup;
+           }
        }
       else
        {
@@ -2915,6 +2919,12 @@ gfc_match_allocate (void)
          goto cleanup;
        }
 
+      if (tail->expr->ts.deferred)
+       {
+         saw_deferred = true;
+         deferred_locus = tail->expr->where;
+       }
+
       /* The ALLOCATE statement had an optional typespec.  Check the
         constraints.  */
       if (ts.type != BT_UNKNOWN)
@@ -2957,8 +2967,8 @@ gfc_match_allocate (void)
                || sym->ns->proc_name->attr.proc_pointer);
       if (b1 && b2 && !b3)
        {
-         gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
-                    "or an allocatable variable");
+         gfc_error ("Allocate-object at %L is not a nonprocedure pointer "
+                    "or an allocatable variable", &tail->expr->where);
          goto cleanup;
        }
 
@@ -3098,7 +3108,6 @@ alloc_opt_list:
          break;
     }
 
-
   if (gfc_match (" )%t") != MATCH_YES)
     goto syntax;
 
@@ -3109,6 +3118,14 @@ alloc_opt_list:
                  &mold->where, &source->where);
       goto cleanup;
     }
+
+  /* Check F03:C623,  */
+  if (saw_deferred && ts.type == BT_UNKNOWN && !source)
+    {
+      gfc_error ("Allocate-object at %L with a deferred type parameter "
+                "requires either a type-spec or SOURCE tag", &deferred_locus);
+      goto cleanup;
+    }
   
   new_st.op = EXEC_ALLOCATE;
   new_st.expr1 = stat;
@@ -4499,9 +4516,9 @@ select_type_set_tmp (gfc_typespec *ts)
     return;
 
   if (ts->type == BT_CLASS)
-    sprintf (name, "tmp$class$%s", ts->u.derived->name);
+    sprintf (name, "__tmp_class_%s", ts->u.derived->name);
   else
-    sprintf (name, "tmp$type$%s", ts->u.derived->name);
+    sprintf (name, "__tmp_type_%s", ts->u.derived->name);
   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
   gfc_add_type (tmp->n.sym, ts, NULL);
   gfc_set_sym_referenced (tmp->n.sym);