aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog18
-rw-r--r--gcc/fortran/decl.c89
-rw-r--r--gcc/fortran/dump-parse-tree.c2
-rw-r--r--gcc/fortran/gfortran.h7
-rw-r--r--gcc/fortran/match.h1
-rw-r--r--gcc/fortran/module.c8
-rw-r--r--gcc/fortran/parse.c3
-rw-r--r--gcc/fortran/resolve.c3
-rw-r--r--gcc/fortran/symbol.c33
9 files changed, 154 insertions, 10 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index dc3aa97..79b5174 100644
--- 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 90f30b3..9f65fe4 100644
--- 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 97289c2..f363816 100644
--- 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 20f52ea..345a701 100644
--- 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 bc19453..3c0f1c0 100644
--- 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 a07af9a..140f2e2 100644
--- 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 98d684f..8f7ec29 100644
--- 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 78b0a78..0378d4f 100644
--- 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 8ba5adb..750aa2d 100644
--- 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);
@@ -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;
generated by cgit v1.1 at 2025-05-01 03:34:30 +0000