This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch, Fortran] F90 rejects valid; ASYNCHRONOUS attribute


I have two fixes included in this patch:

a) Rejects valid F90
b) Complete asynchronous I/O (implemented as synchronous)

Regarding a:

type(t) function func()
   allocatable :: a
   type t
   end type t

was rejected because "allocatable" was not recognized when reparsing - a
problem which only affects "type(...) function ..." type of declarations.

 * * *

Regarding b:
Jerry implemented a while back asynchronous I/O (implemented as
synchronous I/O). However, I just realized that one sometimes needs the
ASYNCHRONOUS attribute for this. Variables gain it automatically when
being used in an async I/O transfer statements, but if one wants to
affirm it or in some other cases, it is really needed. As ASYNCHRONOUS
is similar to VOLATILE, I simply used it as template for the changes. --
It is a relatively small and straight forward change and needed to parse
some programs which use async I/O (advertised in gcc-4.5/changes.html
and F2003status), but one can also argue to hold it off until 4.6.

Build and regtested on x86-64-linux.
OK for the trunk?

Tobias
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.

Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(Revision 155688)
+++ gcc/fortran/symbol.c	(Arbeitskopie)
@@ -369,7 +369,8 @@ check_conflict (symbol_attribute *attr,
     *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,
   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,
   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,
       conf2 (dimension);
       conf2 (dummy);
       conf2 (volatile_);
+      conf2 (asynchronous);
       conf2 (pointer);
       conf2 (is_protected);
       conf2 (target);
@@ -640,8 +646,11 @@ check_conflict (symbol_attribute *attr,
 
       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,
       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
 
 
 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, s
     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;
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(Revision 155688)
+++ gcc/fortran/decl.c	(Arbeitskopie)
@@ -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;
@@ -6484,6 +6512,59 @@ syntax:
   return MATCH_ERROR;
 }
 
+
+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
Index: gcc/fortran/dump-parse-tree.c
===================================================================
--- gcc/fortran/dump-parse-tree.c	(Revision 155688)
+++ gcc/fortran/dump-parse-tree.c	(Arbeitskopie)
@@ -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)
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(Revision 155688)
+++ gcc/fortran/gfortran.h	(Arbeitskopie)
@@ -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_attrib
 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);
 
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(Revision 155688)
+++ gcc/fortran/module.c	(Arbeitskopie)
@@ -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 *
     {
       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 *
 	    case AB_ALLOCATABLE:
 	      attr->allocatable = 1;
 	      break;
+	    case AB_ASYNCHRONOUS:
+	      attr->asynchronous = 1;
+	      break;
 	    case AB_DIMENSION:
 	      attr->dimension = 1;
 	      break;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 155688)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -937,7 +944,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;
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h	(Revision 155688)
+++ gcc/fortran/match.h	(Arbeitskopie)
@@ -162,6 +162,7 @@ void gfc_set_constant_character_len (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);
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c	(Revision 155688)
+++ gcc/fortran/parse.c	(Arbeitskopie)
@@ -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':
Index: gcc/testsuite/gfortran.dg/asynchronous_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/asynchronous_1.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/asynchronous_1.f90	(Revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/asynchronous_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/asynchronous_2.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/asynchronous_2.f90	(Revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/conflicts.f90
===================================================================
--- gcc/testsuite/gfortran.dg/conflicts.f90	(Revision 155688)
+++ gcc/testsuite/gfortran.dg/conflicts.f90	(Arbeitskopie)
@@ -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)
Index: gcc/testsuite/gfortran.dg/c_ptr_tests_14.f90
===================================================================
--- gcc/testsuite/gfortran.dg/c_ptr_tests_14.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/c_ptr_tests_14.f90	(Revision 0)
@@ -0,0 +1,51 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/41298
+!
+! Check that c_null_ptr default initializer is really applied
+
+module m
+  use iso_c_binding
+  type, public :: fgsl_file
+     type(c_ptr)    :: gsl_file = c_null_ptr
+     type(c_funptr) :: gsl_func = c_null_funptr
+     type(c_ptr)    :: NIptr
+     type(c_funptr) :: NIfunptr
+  end type fgsl_file
+contains
+  subroutine sub(aaa,bbb)
+    type(fgsl_file), intent(out)   :: aaa
+    type(fgsl_file), intent(inout) :: bbb
+  end subroutine
+  subroutine proc() bind(C)
+  end subroutine proc
+end module m
+
+program test
+  use m
+  implicit none
+  type(fgsl_file) :: file, noreinit
+  integer, target :: tgt
+
+  call sub(file, noreinit)
+  if(c_associated(file%gsl_file)) call abort()
+  if(c_associated(file%gsl_func)) call abort()
+
+  file%gsl_file = c_loc(tgt)
+  file%gsl_func = c_funloc(proc)
+  call sub(file, noreinit)
+  if(c_associated(file%gsl_file)) call abort()
+  if(c_associated(file%gsl_func)) call abort()
+end program test
+
+! { dg-final { scan-tree-dump-times "gsl_file = 0B" 1 "original" } }
+! { dg-final { scan-tree-dump-times "gsl_func = 0B" 1 "original" } }
+
+! { dg-final { scan-tree-dump-times "NIptr = 0B"    0 "original" } }
+! { dg-final { scan-tree-dump-times "NIfunptr = 0B" 0 "original" } }
+
+! { dg-final { scan-tree-dump-times "bbb =" 0 "original" } }
+
+! { dg-final { cleanup-tree-dump "original" } }
+! { dg-final { cleanup-modules "m" } }

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]