re PR fortran/25829 ([F03] Asynchronous IO support)

2010-01-08  Tobias Burnus  <burnus@net-b.de

        PR/fortran 25829
        * symbol.c (check_conflict, gfc_copy_attr): Add
        ASYNCHRONOUS support.
        (gfc_add_asynchronous): New function.
        * decl.c (match_attr_spec): Add ASYNCHRONOUS support.
        (gfc_match_asynchronous): New function.
        * dump-parse-tree.c (show_attr): Add ASYNCHRONOUS support.
        * gfortran.h (symbol_attribute): New ASYNCHRONOUS bit.
        (gfc_add_asynchronous): New Prototype.
        * module.c (ab_attribute, mio_symbol_attribute): Add
        ASYNCHRONOUS support.
        * resolve.c (was_declared): Ditto.
        * match.h (gfc_match_asynchronous): New prototype.
        * parse.c (decode_specification_statement,decode_statement):
        Add ASYNCHRONOUS support.

2010-01-08  Tobias Burnus  <burnus@net-b.de

        PR/fortran 25829
        * gfortran.dg/asynchronous_1.f90: New test.
        * gfortran.dg/asynchronous_2.f90: New test.
        * gfortran.dg/conflicts.f90: Update error message.

From-SVN: r155732

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index dc3aa9718b1328390cd6e5ce40af6804ad11d13c..79b5174deade6df8757927ae2773645ac9c7dcd9 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,21 @@
+2010-01-08  Tobias Burnus  <burnus@net-b.de
+
+       PR/fortran 25829
+       * symbol.c (check_conflict, gfc_copy_attr): Add
+       ASYNCHRONOUS support.
+       (gfc_add_asynchronous): New function.
+       * decl.c (match_attr_spec): Add ASYNCHRONOUS support.
+       (gfc_match_asynchronous): New function.
+       * dump-parse-tree.c (show_attr): Add ASYNCHRONOUS support.
+       * gfortran.h (symbol_attribute): New ASYNCHRONOUS bit.
+       (gfc_add_asynchronous): New Prototype.
+       * module.c (ab_attribute, mio_symbol_attribute): Add
+       ASYNCHRONOUS support.
+       * resolve.c (was_declared): Ditto.
+       * match.h (gfc_match_asynchronous): New prototype.
+       * parse.c (decode_specification_statement,decode_statement):
+       Add ASYNCHRONOUS support.
+
 2010-01-07  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/42597

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 90f30b321753719cfb1ea029281a3c42e7fcd600..9f65fe41eec0314a18e4eb60b8ff7f9d2e995a15 100644 (file)
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -2819,7 +2819,7 @@ match_attr_spec (void)
     DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
     DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
     DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
-    DECL_IS_BIND_C, DECL_NONE,
+    DECL_IS_BIND_C, DECL_ASYNCHRONOUS, DECL_NONE,
     GFC_DECL_END /* Sentinel */
   }
   decl_types;
@@ -2864,9 +2864,25 @@ match_attr_spec (void)
          switch (gfc_peek_ascii_char ())
            {
            case 'a':
-             if (match_string_p ("allocatable"))
-               d = DECL_ALLOCATABLE;
-             break;
+             gfc_next_ascii_char ();
+             switch (gfc_next_ascii_char ())
+               {
+               case 'l':
+                 if (match_string_p ("locatable"))
+                   {
+                     /* Matched "allocatable".  */
+                     d = DECL_ALLOCATABLE;
+                   }
+                 break;
+
+               case 's':
+                 if (match_string_p ("ynchronous"))
+                   {
+                     /* Matched "asynchronous".  */
+                     d = DECL_ASYNCHRONOUS;
+                   }
+                 break;
+               }
 
            case 'b':
              /* Try and match the bind(c).  */
@@ -3047,6 +3063,9 @@ match_attr_spec (void)
          case DECL_ALLOCATABLE:
            attr = "ALLOCATABLE";
            break;
+         case DECL_ASYNCHRONOUS:
+           attr = "ASYNCHRONOUS";
+           break;
          case DECL_DIMENSION:
            attr = "DIMENSION";
            break;
@@ -3173,6 +3192,15 @@ match_attr_spec (void)
          t = gfc_add_allocatable (&current_attr, &seen_at[d]);
          break;
 
+       case DECL_ASYNCHRONOUS:
+         if (gfc_notify_std (GFC_STD_F2003,
+                             "Fortran 2003: ASYNCHRONOUS attribute at %C")
+             == FAILURE)
+           t = FAILURE;
+         else
+           t = gfc_add_asynchronous (&current_attr, NULL, &seen_at[d]);
+         break;
+
        case DECL_DIMENSION:
          t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
          break;
@@ -6485,6 +6513,59 @@ syntax:
 }
 
 
+match
+gfc_match_asynchronous (void)
+{
+  gfc_symbol *sym;
+  match m;
+
+  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASYNCHRONOUS statement at %C")
+      == FAILURE)
+    return MATCH_ERROR;
+
+  if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
+    {
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_eos () == MATCH_YES)
+    goto syntax;
+
+  for(;;)
+    {
+      /* ASYNCHRONOUS is special because it can be added to host-associated 
+        symbols locally.  */
+      m = gfc_match_symbol (&sym, 1);
+      switch (m)
+       {
+       case MATCH_YES:
+         if (gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus)
+             == FAILURE)
+           return MATCH_ERROR;
+         goto next_item;
+
+       case MATCH_NO:
+         break;
+
+       case MATCH_ERROR:
+         return MATCH_ERROR;
+       }
+
+    next_item:
+      if (gfc_match_eos () == MATCH_YES)
+       break;
+      if (gfc_match_char (',') != MATCH_YES)
+       goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
+  return MATCH_ERROR;
+}
+
+
 /* Match a module procedure statement.  Note that we have to modify
    symbols in the parent's namespace because the current one was there
    to receive symbols that are in an interface's formal argument list.  */

diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 97289c26aa5926e215ded72d59f08c43c738c10b..f3638167dfb402a9bc6a5ff1751691dde8b6a4fe 100644 (file)
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -589,6 +589,8 @@ show_attr (symbol_attribute *attr)
 
   if (attr->allocatable)
     fputs (" ALLOCATABLE", dumpfile);
+  if (attr->asynchronous)
+    fputs (" ASYNCHRONOUS", dumpfile);
   if (attr->dimension)
     fputs (" DIMENSION", dumpfile);
   if (attr->external)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 20f52eaed32a7dcfd4b561addff3cf42256842bc..345a7015dce3c2ae9537147497a152a3513bb507 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -652,7 +652,7 @@ typedef struct
   unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
     optional:1, pointer:1, target:1, value:1, volatile_:1, temporary:1,
     dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
-    implied_index:1, subref_array_pointer:1, proc_pointer:1;
+    implied_index:1, subref_array_pointer:1, proc_pointer:1, asynchronous:1;
 
   /* For CLASS containers, the pointer attribute is sometimes set internally
      even though it was not directly specified.  In this case, keep the
@@ -741,8 +741,8 @@ typedef struct
   /* Attributes set by compiler extensions (!GCC$ ATTRIBUTES).  */
   unsigned ext_attr:EXT_ATTR_NUM;
 
-  /* The namespace where the VOLATILE attribute has been set.  */
-  struct gfc_namespace *volatile_ns;
+  /* The namespace where the attribute has been set.  */
+  struct gfc_namespace *volatile_ns, *asynchronous_ns;
 }
 symbol_attribute;
 
@@ -2426,6 +2426,7 @@ gfc_try gfc_add_recursive (symbol_attribute *, locus *);
 gfc_try gfc_add_function (symbol_attribute *, const char *, locus *);
 gfc_try gfc_add_subroutine (symbol_attribute *, const char *, locus *);
 gfc_try gfc_add_volatile (symbol_attribute *, const char *, locus *);
+gfc_try gfc_add_asynchronous (symbol_attribute *, const char *, locus *);
 gfc_try gfc_add_proc (symbol_attribute *attr, const char *name, locus *where);
 gfc_try gfc_add_abstract (symbol_attribute* attr, locus* where);
 

diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index bc1945302c92b8768e97bcacc8d735b87894df26..3c0f1c0de496343b50985d2d63ae74728f774bea 100644 (file)
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -162,6 +162,7 @@ void gfc_set_constant_character_len (int, gfc_expr *, int);
 
 /* Matchers for attribute declarations.  */
 match gfc_match_allocatable (void);
+match gfc_match_asynchronous (void);
 match gfc_match_dimension (void);
 match gfc_match_external (void);
 match gfc_match_gcc_attributes (void);

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index a07af9a813f9e235cc754947ed26de1e7d44ef8c..140f2e2d5745d5c1be93fae92e2d4d8742c39fa8 100644 (file)
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1671,13 +1671,14 @@ typedef enum
   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
   AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
   AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
-  AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER
+  AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS
 }
 ab_attribute;
 
 static const mstring attr_bits[] =
 {
     minit ("ALLOCATABLE", AB_ALLOCATABLE),
+    minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
     minit ("DIMENSION", AB_DIMENSION),
     minit ("EXTERNAL", AB_EXTERNAL),
     minit ("INTRINSIC", AB_INTRINSIC),
@@ -1792,6 +1793,8 @@ mio_symbol_attribute (symbol_attribute *attr)
     {
       if (attr->allocatable)
        MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
+      if (attr->asynchronous)
+       MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
       if (attr->dimension)
        MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
       if (attr->external)
@@ -1887,6 +1890,9 @@ mio_symbol_attribute (symbol_attribute *attr)
            case AB_ALLOCATABLE:
              attr->allocatable = 1;
              break;
+           case AB_ASYNCHRONOUS:
+             attr->asynchronous = 1;
+             break;
            case AB_DIMENSION:
              attr->dimension = 1;
              break;

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 98d684ff86cc0c4f3c7cfe801331ef1ec3defcd7..8f7ec29f1ad7f60e32110f0f87aff6614f530b5f 100644 (file)
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -129,6 +129,8 @@ decode_specification_statement (void)
     case 'a':
       match ("abstract% interface", gfc_match_abstract_interface,
             ST_INTERFACE);
+      match ("allocatable", gfc_match_asynchronous, ST_ATTR_DECL);
+      match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
       break;
 
     case 'b':
@@ -328,6 +330,7 @@ decode_statement (void)
       match ("allocate", gfc_match_allocate, ST_ALLOCATE);
       match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
       match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
+      match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
       break;
 
     case 'b':

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 78b0a7850d6c1a22c595997b2f884e91aab5626d..0378d4fa14ad9ebb94de9f82f3a160c2f97e681e 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -937,7 +937,8 @@ was_declared (gfc_symbol *sym)
 
   if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
       || a.optional || a.pointer || a.save || a.target || a.volatile_
-      || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
+      || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
+      || a.asynchronous)
     return 1;
 
   return 0;

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 8ba5adb51c2090fd1d944c7cdaea713734d04725..750aa2d6a16ee503981f492db4d726944f5d95e8 100644 (file)
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -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);
@@ -1099,6 +1109,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;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 410b6dcf7fa9558a698eab9ee4df8fcc3843f73d..e96fbd2d4a47f9639cdbed70f5fe099629597f64 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2010-01-08  Tobias Burnus  <burnus@net-b.de
+
+       PR/fortran 25829
+       * gfortran.dg/asynchronous_1.f90: New test.
+       * gfortran.dg/asynchronous_2.f90: New test.
+       * gfortran.dg/conflicts.f90: Update error message.
+
 2010-01-07  Dodji Seketeli  <dodji@redhat.com>
 
        c++/40155

diff --git a/gcc/testsuite/gfortran.dg/asynchronous_1.f90 b/gcc/testsuite/gfortran.dg/asynchronous_1.f90
new file mode 100644 (file)
index 0000000..bc88214
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/asynchronous_1.f90
@@ -0,0 +1,42 @@
+! { dg-do compile }
+!
+! PR/fortran 25829
+!
+! Check parsing and checking of ASYNCHRONOUS
+!
+type(t) function func0()
+  asynchronous :: a
+  integer, asynchronous:: b
+  allocatable :: c
+  volatile :: d
+  type t
+    sequence
+    integer :: i = 5
+  end type t
+end function func0
+
+integer function func()
+  asynchronous :: func
+  integer, asynchronous:: b
+  allocatable :: c
+  volatile :: func
+  type t
+    sequence
+    integer :: i = 5
+  end type t
+end function func
+
+function func2() result(res)
+  volatile res
+  asynchronous res
+end function func2
+
+subroutine sub()
+  asynchronous sub ! { dg-error "SUBROUTINE attribute conflicts with ASYNCHRONOUS" }
+  volatile sub     ! { dg-error "SUBROUTINE attribute conflicts with VOLATILE" }
+end subroutine sub
+
+program main
+  asynchronous main ! { dg-error "PROGRAM attribute conflicts with ASYNCHRONOUS" }
+  volatile main     ! { dg-error "PROGRAM attribute conflicts with VOLATILE" }
+end program main

diff --git a/gcc/testsuite/gfortran.dg/asynchronous_2.f90 b/gcc/testsuite/gfortran.dg/asynchronous_2.f90
new file mode 100644 (file)
index 0000000..939c9e2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/asynchronous_2.f90
@@ -0,0 +1,10 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+!
+! PR/fortran 25829
+!
+! Check parsing ASYNCHRONOUS
+!
+function func2() result(res)
+  asynchronous res ! { dg-error "Fortran 2003: ASYNCHRONOUS" }
+end function func2

diff --git a/gcc/testsuite/gfortran.dg/conflicts.f90 b/gcc/testsuite/gfortran.dg/conflicts.f90
index 1f10a65ceedaf50a3596d654f58a8b1bde030c35..d17cb041db6dbe6e1e9610657801279aa4a30cd6 100644 (file)
--- a/gcc/testsuite/gfortran.dg/conflicts.f90
+++ b/gcc/testsuite/gfortran.dg/conflicts.f90
@@ -17,7 +17,7 @@ end function f2
 
 subroutine f3()
   implicit none
-  dimension f3(3) ! { dg-error "PROCEDURE attribute conflicts with DIMENSION attribute" }
+  dimension f3(3) ! { dg-error "SUBROUTINE attribute conflicts with DIMENSION attribute" }
 end subroutine f3
 
 subroutine f4(b)