2006-12-03 Paul Thomas <pault@gcc.gnu.org>

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

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 07bf265..228567b 100644 (file)
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -266,6 +266,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
   static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
     *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
     *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
+    *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
     *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
     *private = "PRIVATE", *recursive = "RECURSIVE",
     *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
@@ -273,7 +274,8 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
     *function = "FUNCTION", *subroutine = "SUBROUTINE",
     *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
     *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
-    *cray_pointee = "CRAY POINTEE", *data = "DATA", *volatile_ = "VOLATILE";
+    *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
+    *volatile_ = "VOLATILE";
   static const char *threadprivate = "THREADPRIVATE";
 
   const char *a1, *a2;
@@ -318,6 +320,8 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
        }
     }
 
+  conf (dummy, entry);
+  conf (dummy, intrinsic);
   conf (dummy, save);
   conf (dummy, threadprivate);
   conf (pointer, target);
@@ -400,6 +404,21 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
   conf (data, allocatable);
   conf (data, use_assoc);
 
+  conf (value, pointer)
+  conf (value, allocatable)
+  conf (value, subroutine)
+  conf (value, function)
+  conf (value, volatile_)
+  conf (value, dimension)
+  conf (value, external)
+
+  if (attr->value && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
+    {
+      a1 = value;
+      a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
+      goto conflict;
+    }
+
   conf (volatile_, intrinsic)
   conf (volatile_, external)
 
@@ -427,8 +446,10 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
     case FL_BLOCK_DATA:
     case FL_MODULE:
     case FL_LABEL:
+      conf2 (dimension);
       conf2 (dummy);
       conf2 (save);
+      conf2 (volatile_);
       conf2 (pointer);
       conf2 (target);
       conf2 (external);
@@ -448,15 +469,16 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
 
     case FL_PROCEDURE:
       conf2 (intent);
+      conf2(save);
 
       if (attr->subroutine)
        {
-         conf2(save);
          conf2(pointer);
          conf2(target);
          conf2(allocatable);
          conf2(result);
          conf2(in_namelist);
+         conf2(dimension);
          conf2(function);
          conf2(threadprivate);
        }
@@ -519,6 +541,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
       conf2 (dummy);
       conf2 (in_common);
       conf2 (save);
+      conf2 (value);
       conf2 (volatile_);
       conf2 (threadprivate);
       break;
@@ -601,28 +624,6 @@ check_used (symbol_attribute * attr, const char * name, locus * where)
 }
 
 
-/* Used to prevent changing the attributes of a symbol after it has been
-   used.  This check is only done for dummy variables as only these can be
-   used in specification expressions.  Applying this to all symbols causes
-   an error when we reach the body of a contained function.  */
-
-static int
-check_done (symbol_attribute * attr, locus * where)
-{
-
-  if (!(attr->dummy && attr->referenced))
-    return 0;
-
-  if (where == NULL)
-    where = &gfc_current_locus;
-
-  gfc_error ("Cannot change attributes of symbol at %L"
-             " after it has been used", where);
-
-  return 1;
-}
-
-
 /* Generate an error because of a duplicate attribute.  */
 
 static void
@@ -638,12 +639,9 @@ duplicate_attr (const char *attr, locus * where)
 /* Called from decl.c (attr_decl1) to check attributes, when declared separately.  */
 
 try
-gfc_add_attribute (symbol_attribute * attr, locus * where,
-                  unsigned int attr_intent)
+gfc_add_attribute (symbol_attribute * attr, locus * where)
 {
-
-  if (check_used (attr, NULL, where)
-       || (attr_intent == 0 && check_done (attr, where)))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   return check_conflict (attr, NULL, where);
@@ -653,7 +651,7 @@ try
 gfc_add_allocatable (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   if (attr->allocatable)
@@ -671,7 +669,7 @@ try
 gfc_add_dimension (symbol_attribute * attr, const char *name, locus * where)
 {
 
-  if (check_used (attr, name, where) || check_done (attr, where))
+  if (check_used (attr, name, where))
     return FAILURE;
 
   if (attr->dimension)
@@ -689,7 +687,7 @@ try
 gfc_add_external (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   if (attr->external)
@@ -708,7 +706,7 @@ try
 gfc_add_intrinsic (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   if (attr->intrinsic)
@@ -727,7 +725,7 @@ try
 gfc_add_optional (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   if (attr->optional)
@@ -745,7 +743,7 @@ try
 gfc_add_pointer (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   attr->pointer = 1;
@@ -757,7 +755,7 @@ try
 gfc_add_cray_pointer (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   attr->cray_pointer = 1;
@@ -769,13 +767,13 @@ try
 gfc_add_cray_pointee (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   if (attr->cray_pointee)
     {
       gfc_error ("Cray Pointee at %L appears in multiple pointer()"
-                " statements.", where);
+                " statements", where);
       return FAILURE;
     }
 
@@ -788,7 +786,7 @@ try
 gfc_add_result (symbol_attribute * attr, const char *name, locus * where)
 {
 
-  if (check_used (attr, name, where) || check_done (attr, where))
+  if (check_used (attr, name, where))
     return FAILURE;
 
   attr->result = 1;
@@ -825,6 +823,26 @@ gfc_add_save (symbol_attribute * attr, const char *name, locus * where)
 }
 
 try
+gfc_add_value (symbol_attribute * attr, const char *name, locus * where)
+{
+
+  if (check_used (attr, name, where))
+    return FAILURE;
+
+  if (attr->value)
+    {
+       if (gfc_notify_std (GFC_STD_LEGACY, 
+                           "Duplicate VALUE attribute specified at %L",
+                           where) 
+           == FAILURE)
+         return FAILURE;
+    }
+
+  attr->value = 1;
+  return check_conflict (attr, name, where);
+}
+
+try
 gfc_add_volatile (symbol_attribute * attr, const char *name, locus * where)
 {
 
@@ -866,7 +884,7 @@ try
 gfc_add_target (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   if (attr->target)
@@ -897,7 +915,7 @@ try
 gfc_add_in_common (symbol_attribute * attr, const char *name, locus * where)
 {
 
-  if (check_used (attr, name, where) || check_done (attr, where))
+  if (check_used (attr, name, where))
     return FAILURE;
 
   /* Duplicate attribute already checked for.  */
@@ -965,7 +983,7 @@ try
 gfc_add_elemental (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   attr->elemental = 1;
@@ -977,7 +995,7 @@ try
 gfc_add_pure (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   attr->pure = 1;
@@ -989,7 +1007,7 @@ try
 gfc_add_recursive (symbol_attribute * attr, locus * where)
 {
 
-  if (check_used (attr, NULL, where) || check_done (attr, where))
+  if (check_used (attr, NULL, where))
     return FAILURE;
 
   attr->recursive = 1;
@@ -1093,7 +1111,7 @@ gfc_add_procedure (symbol_attribute * attr, procedure_type t,
                   const char *name, locus * where)
 {
 
-  if (check_used (attr, name, where) || check_done (attr, where))
+  if (check_used (attr, name, where))
     return FAILURE;
 
   if (attr->flavor != FL_PROCEDURE
@@ -1202,10 +1220,6 @@ gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where)
 {
   sym_flavor flavor;
 
-/* TODO: This is legal if it is reaffirming an implicit type.
-  if (check_done (&sym->attr, where))
-    return FAILURE;*/
-
   if (where == NULL)
     where = &gfc_current_locus;
 
@@ -1281,6 +1295,8 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
     goto fail;
   if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
     goto fail;
+  if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
+    goto fail;
   if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
     goto fail;
   if (src->threadprivate && gfc_add_threadprivate (dest, NULL, where) == FAILURE)