* sv.po: Update.

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

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 6dd0a8a..a5787de 100644 (file)
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -1,6 +1,6 @@
 /* Maintain binary trees of symbols.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
-   Free Software Foundation, Inc.
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+   2009, 2010 Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
 This file is part of GCC.
@@ -369,7 +369,8 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
     *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
     *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
     *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
-    *is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
+    *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
+    *asynchronous = "ASYNCHRONOUS";
   static const char *threadprivate = "THREADPRIVATE";
 
   const char *a1, *a2;
@@ -559,6 +560,9 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (is_protected, external)
   conf (is_protected, in_common)
 
+  conf (asynchronous, intrinsic)
+  conf (asynchronous, external)
+
   conf (volatile_, intrinsic)
   conf (volatile_, external)
 
@@ -576,6 +580,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (procedure, target)
   conf (procedure, value)
   conf (procedure, volatile_)
+  conf (procedure, asynchronous)
   conf (procedure, entry)
 
   a1 = gfc_code2string (flavors, attr->flavor);
@@ -598,6 +603,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       conf2 (dimension);
       conf2 (dummy);
       conf2 (volatile_);
+      conf2 (asynchronous);
       conf2 (pointer);
       conf2 (is_protected);
       conf2 (target);
@@ -640,8 +646,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
 
       if (attr->subroutine)
        {
+         a1 = subroutine;
          conf2 (target);
          conf2 (allocatable);
+         conf2 (volatile_);
+         conf2 (asynchronous);
          conf2 (in_namelist);
          conf2 (dimension);
          conf2 (function);
@@ -708,6 +717,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       conf2 (in_common);
       conf2 (value);
       conf2 (volatile_);
+      conf2 (asynchronous);
       conf2 (threadprivate);
       conf2 (value);
       conf2 (is_bind_c);
@@ -1100,6 +1110,25 @@ gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
 
 
 gfc_try
+gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
+{
+  /* No check_used needed as 11.2.1 of the F2003 standard allows
+     that the local identifier made accessible by a use statement can be
+     given a ASYNCHRONOUS attribute.  */
+
+  if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
+    if (gfc_notify_std (GFC_STD_LEGACY, 
+                       "Duplicate ASYNCHRONOUS attribute specified at %L",
+                       where) == FAILURE)
+      return FAILURE;
+
+  attr->asynchronous = 1;
+  attr->asynchronous_ns = gfc_current_ns;
+  return check_conflict (attr, name, where);
+}
+
+
+gfc_try
 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
 {
 
@@ -1659,6 +1688,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
     goto fail;
   if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
     goto fail;
+  if (src->asynchronous && gfc_add_asynchronous (dest, NULL, where) == FAILURE)
+    goto fail;
   if (src->threadprivate
       && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
     goto fail;
@@ -2476,7 +2507,7 @@ select_type_insert_tmp (gfc_symtree **st)
 {
   gfc_select_type_stack *stack = select_type_stack;
   for (; stack; stack = stack->prev)
-    if ((*st)->n.sym == stack->selector)
+    if ((*st)->n.sym == stack->selector && stack->tmp)
       *st = stack->tmp;
 }
 
@@ -3659,10 +3690,10 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
   tmp_sym->value->expr_type = EXPR_STRUCTURE;
   tmp_sym->value->ts.type = BT_DERIVED;
   tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
-  /* Create a constructor with no expr, that way we can recognize if the user
-     tries to call the structure constructor for one of the iso_c_binding
-     derived types during resolution (resolve_structure_cons).  */
   tmp_sym->value->value.constructor = gfc_get_constructor ();
+  tmp_sym->value->value.constructor->expr = gfc_get_expr ();
+  tmp_sym->value->value.constructor->expr->expr_type = EXPR_NULL;
+  tmp_sym->value->value.constructor->expr->ts.is_iso_c = 1;
   /* Must declare c_null_ptr and c_null_funptr as having the
      PARAMETER attribute so they can be used in init expressions.  */
   tmp_sym->attr.flavor = FL_PARAMETER;
@@ -4681,6 +4712,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       c->ts.type = BT_DERIVED;
       c->attr.access = ACCESS_PRIVATE;
       c->ts.u.derived = ts->u.derived;
+      c->attr.class_pointer = attr->pointer;
       c->attr.pointer = attr->pointer || attr->dummy;
       c->attr.allocatable = attr->allocatable;
       c->attr.dimension = attr->dimension;
@@ -4747,6 +4779,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
          vtab->attr.target = 1;
          vtab->attr.save = SAVE_EXPLICIT;
          vtab->attr.vtab = 1;
+         vtab->attr.access = ACCESS_PRIVATE;
          vtab->refs++;
          gfc_set_sym_referenced (vtab);
          sprintf (name, "vtype$%s", derived->name);
@@ -4763,6 +4796,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
                return NULL;
              vtype->refs++;
              gfc_set_sym_referenced (vtype);
+             vtype->attr.access = ACCESS_PRIVATE;
 
              /* Add component '$hash'.  */
              if (gfc_add_component (vtype, "$hash", &c) == FAILURE)